c
c Symbol library
c
c Symbols are stored in VM.
c all information is in a control block. The pointer to this 
c control block is saved in control.p_symbols
c
c Symbols have two attributes
c  1. symbol name
c  2. symbol value
c The names are a linked list with its header in symbol_control.ptr_symbols
c the values are a linked list with its header in symbol_name.ptr_values 
c
c A symbol can have more than one value, the context level
c  defines the actual value. So if a command procedure
c  defines a symbol TEST, and then calls another procedure
c  that defines TEST again, the previous value of TEST is unaccessible.
c
	subroutine dix_symbol_init(control)
	implicit none
c
c Initialize the symbol table
c
	include 'dix_symbol.inc'
	record /control/ control	!:io: control structure
c#
	record /main_symbol/ main_symbol
	pointer (p_main_symbol,main_symbol) 
c
	record /symbol/ symbol
	record /symbol_value/ symbol_value
c
	call get_vm(control,sizeof(main_symbol),p_main_symbol,
     1              control.zone_general,.false.,'MAIN_SYMBOL')
	control.p_symbols = p_main_symbol
c
	main_symbol.magic = magic_main_symbol
	main_symbol.ptr_symbols       = 0
	main_symbol.ptr_spare_names   = 0
	main_symbol.ptr_spare_values  = 0
	main_symbol.enters            = 0
	main_symbol.removes           = 0
	main_symbol.rewrites          = 0
	main_symbol.lookups           = 0
c
	call init_vm(control,main_symbol.zone_symbol,sizeof(symbol),
     1              'SYMBOL_ZONE',.false.)
	call init_vm(control,main_symbol.zone_symbol_value,
     1               sizeof(symbol_value),
     1              'SYMBOL_VALUE_ZONE',.false.)
c
	call dix_main_print_debug(control,debug_symbols,
     1             'Symbol table created')
	return
	end
c
	function dix_symbol_check_name(symbol,des_expanded,err_arg)
	implicit none
c
c CHeck if the name is a valid symbol name
c Check for the rules (first chr alpha, etc..)
c  if des_expanded <>0 check if the symbol is a field value
c
	include 'dix_symbol.inc'
c
	character*(*) symbol    	!:i: symbolname
	record /des_expanded/ des_expanded !:i: currently defined fields
	character*(*) err_arg		!:o: error argument (if error)
	logical dix_symbol_check_name	!:f: function result
c#
	integer*4 k,istat
	logical dix_util_check_name
c
	record /des_rec/ des_recs(1)
	pointer (p_des_recs,des_recs)
c
	external dix_msg_symbisfld
	integer*4 dix_util_str_eq

	dix_symbol_check_name = .false.
c
	istat = dix_util_check_name(symbol)
	if(.not. istat) then
	  err_arg = symbol
	  goto 90
	endif
	if(%loc(des_expanded) .ne. 0) then
c
c See if previously defined as a field name
c
	  p_des_recs = des_expanded.table_nor.address
	  do k=1,des_expanded.table_nor.count
	    if(dix_util_str_eq(des_recs(k).nam,symbol)) goto 80
	  end do
	  p_des_recs = des_expanded.table_vfc.address
	  do k=1,des_expanded.table_vfc.count
	    if(dix_util_str_eq(des_recs(k).nam,symbol)) goto 80
	  end do
	endif
	istat = 1
	goto 90
80	err_arg = symbol
	istat = %loc(dix_msg_symbisfld)
90	dix_symbol_check_name = istat
	return
	end
	function dix_symbol_add_int(control,name,intval,err_arg)
	implicit none
c
c (re) define an integer symbol
c  this is a jacket for dix_symbol_add_value for an integer value
c
	include 'dix_symbol.inc'
	record /control/ control	!:io: control sturcture	
	character*(*) name		!:i: the name of the symbol
	integer*4 intval		!:i: the integer value
	character*(*) err_arg		!:o: the error argument
	integer*4 dix_symbol_add_int
c#
	record /value/ val		!:i: the type
c
	integer*4 dix_symbol_add_value
c
c Define a value structure
c
	call dix_eval_init_value(val)
	val.type = symb_typ_int
	val.ival = intval
	call dix_eval_sign_extend(val)
c
c And add /redefine the symbol
c
	dix_symbol_add_int = dix_symbol_add_value(control,name,val,0,
     1                   err_arg,.false.,' ')
	call dix_eval_free_value(val)
	return
	end
	function dix_symbol_add_str(control,name,strval,err_arg)
	implicit none
c
c (re) define an string symbol
c this is a jacket for dix_add_symbol_Value for a string value
c
	include 'dix_symbol.inc'
	record /control/ control	!:io: control sturcture	
	character*(*) name		!:i: the name of the symbol
	character*(*) strval         	!:i: the value
	character*(*) err_arg		!:o: the error argument
	integer*4 dix_symbol_add_str
c#
	record /value/ val		!:i: the type
c
	integer*4 dix_symbol_add_value
c
c Define a value structure
c
	call dix_eval_init_value(val)
	call dix_eval_fill_char(val.strdes,strval)
	val.type = symb_typ_char
c
c And add /redefine the symbol
c
	dix_symbol_add_str = dix_symbol_add_value(control,name,val,0,
     1                   err_arg,.false.,' ')
	call dix_eval_free_value(val)
	return
	end
	function dix_symbol_add(control,name,val,err_arg)
	implicit none
c
c (re) define a symbol
c
	include 'dix_symbol.inc'
	record /control/ control	!:io: control sturcture	
	character*(*) name		!:i: the name of the symbol
	record /value/ val		!:i: the type
	character*(*) err_arg		!:o: the error argument
	integer*4 dix_symbol_add
c#
	integer*4 dix_symbol_add_value
c
	dix_symbol_add = dix_symbol_add_value(control,name,val,0,
     1                   err_arg,.false.,' ')
	return
	end
	function dix_symbol_add_level(control,name,val,err_arg,fixed,secure)
	implicit none
c
c Define a new symbol at the current level
c
	include 'dix_symbol.inc'
	record /control/ control	!:io: control sturcture	
	character*(*) name		!:i: the name of the symbol
	record /value/ val		!:i: the type
	character*(*) err_arg		!:o: the error argument
	logical*4 fixed			!:i: its this a fixed type
	character*(*) secure		!:i: secure variablename
	integer*4 dix_symbol_add_level
c#
	integer*4 dix_symbol_get_level
	integer*4 dix_symbol_add_value
c
	dix_symbol_add_level = dix_symbol_add_value(control,name,val,
     1            dix_symbol_get_level(control),err_arg,fixed,secure)
	end
	function dix_symbol_add_value(control,symb_name,val,level,err_arg,
     1             fixed,secure)
	implicit none
c
c (re) define a symbol at a specified level
c The symbol name may contain an *. This  behaves just like DCL
c
	include 'dix_symbol.inc'
c
	record /control/ control	!:io: control sturcture	
	character*(*) symb_name		!:i: the name of the symbol
	record /value/ val		!:i: the type
	integer*4 level			!:i: the level
	character*(*) err_arg		!:o: the error argument
	logical fixed			!:i: is this a fixed type
	character*(*) secure		!:i: secure var?
	integer*4 dix_symbol_add_value	!:f: funtion result
c#
	record /main_symbol/ main_symbol
	pointer (p_main_symbol,main_symbol)
c
	record /symbol/ symbol
	pointer (p_symbol,symbol)
c
	record /symbol_value/ symbol_value
	pointer (p_symbol_value,symbol_value)
c
	integer*4 istat,k,nk,last_ptr,save_ptr,nk_ast,nk_name
c
	character*(max_symbol_name_length) name
c
	external dix_msg_wrongtype
	external dix_msg_undecl
	external dix_msg_protected
	external dix_msg_absymd
	integer*4 dix_util_get_len
	integer*4 nk_deb,nk_deb1
	character*(max_line_length) debug_line
	record /level/ level_deb
	character*5 deb_nam
c
c See if we already have this symbol defined
c Check the hash value for speed
c
	p_main_symbol = control.p_symbols
c
	if((control.debug .and. debug_symbols) .ne. 0) then
	  call lib$movc3(sizeof(level),level,level_deb)
	  call dix_symbol_type(val,deb_nam,nk_deb1,.true.,.false.)
	  nk_deb = 0
	  call sys$fao('Wants to add !AS symbol !AS at level !UL.!UL'//
     1           ' Fixed !UL, secure !AS',
     1           nk_deb,debug_line,
     1           deb_nam(1:nk_deb1),symb_name,
     1           %val(level_deb.depth),
     1           %val(level_deb.struct_level),
     1           %val(iand(fixed,1)),secure)
	  call dix_main_print_debug(control,debug_symbols,
     1         debug_line(1:nk_deb))
	endif
	nk_deb = 0	
c
c Go find the symbol
c
	nk_ast = index(symb_name,'*')
	nk_name = dix_util_get_len(symb_name)
	if(nk_ast .ne. 0) then
	  name = symb_name(1:nk_ast-1)//symb_name(nk_ast+1:)
	  nk_name = nk_name - 1
	  nk_ast = nk_ast   - 1
	else
	  nk_ast = nk_name
	  name   = symb_name(1:nk_name)
	endif
c
	last_ptr = 0
	p_symbol = main_symbol.ptr_symbols
	do while(p_symbol .ne. 0)
c
c if current symbol is < searched symbol we can stop
c since symbols are keep in sorted order 
c 
c  If there is an * present
c  the part upto the * must be the same -> match
c        and then the part after the * must be the same or longer
c
c  4 possibilities
c
	  if(nk_Ast .lt. nk_name) then
	    if(symbol.nk_ast .lt. symbol.nk_name) then
c
c The new symbol has a * in it, and the table symbol also
c if the part before the * is different, we must trythe next
c
	      if(nk_ast .ne. symbol.nk_ast) goto 5
	      if(name(1:nk_ast) .ne. symbol.name(1:nk_ast)) goto 5
c
c The part before the * is the same, now the part after
c  the * must be the same or longer
c
	      if(nk_name .lt. symbol.nk_name) goto 80
	      if(name(1:symbol.nk_name) .ne. 
     1           symbol.name(1:symbol.nk_name)) goto 80
	      goto 20	!allright
	    else
c
c The new symbol has a * in it, and the table symbol not
c
	      if(nk_ast .gt. symbol.nk_name) goto 5
	      if(name(1:nk_ast) .ne. symbol.name(1:nk_ast)) goto 5
c
c The part before the * is the same, now the rest may not be
c
	      if(nk_name .lt. symbol.nk_name) goto 5
	      if(       name(1:symbol.nk_name) .ne. 
     1           symbol.name(1:symbol.nk_name)) goto 5
	      goto 80	!wrong
	    endif
	  else
	    if(symbol.nk_ast .lt. symbol.nk_name) then
c
c The new symbol has NO * in it, and the table symbol does
c
	      if(nk_name .lt. symbol.nk_ast) goto 5
	      if(       name(1:symbol.nk_ast) .ne. 
     1           symbol.name(1:symbol.nk_ast)) goto 5
c
c Now the part before the * is the same, see about the rest
c
	      if(nk_name .ne. symbol.nk_name) goto 80
	      if(       name(1:nk_name) .ne. 
     1           symbol.name(1:nk_name)) goto 80
	      goto 20
	    else
c
c The new symbol has NO * in it, and the table symbol not
c
	      if(symbol.name(1:symbol.nk_name) .eq. 
     1                  name(1:nk_name)) goto 20
	    endif
	  endif
c
c No match, try the next
c
5	  if(symbol.name(1:symbol.nk_ast) .gt. name(1:nk_ast)) goto 10
	  last_ptr = p_symbol
	  p_symbol = symbol.ptr_next
	end do
c
c Not found, so now add a new symbol
c It must be inserted just after last_ptr
c  Check if add of a symbol is allowed
c
10	if((iand(control.strict_mode,strict_declaration) .ne. 0) .and.
     1           level .eq. 0) then
c
c We are in strict declaration mode, if somebody tries to define
c a symbol (and it is not a special one), return error
c
	  if(name(1:1) .ne. '$' .and. name(1:1) .ne. '%') then
	    istat= %loc(dix_msg_undecl)
	    err_arg = name
	    goto 90
	  endif
	endif
c
c Now add a symbol
c
	if((control.debug .and. debug_symbols) .ne. 0) then
	  call dix_append(nk_deb,debug_line,'Add new symbol,')
	endif
	main_symbol.enters = main_symbol.enters + 1
c
c Check if we have a free entry in the "spare" cache
c
	if(main_symbol.ptr_spare_names .ne. 0) then
c
c Get one from the cache
c
	  p_symbol = main_symbol.ptr_spare_names
	  main_symbol.ptr_spare_names = symbol.ptr_next
	else
c
c Allocate a new one
c
	  call get_vm(control,sizeof(symbol),p_symbol,
     1                 main_symbol.zone_symbol,.false.,'SYMBOL')
	  symbol.magic = magic_symbol
	endif
c
c Now fill the symbol name record
c with no values and cleared counters
c 
	symbol.ptr_values = 0
	symbol.ptr_next   = 0
	symbol.lookups    = 0
	symbol.rewrites   = 0
c
c Now insert in (sorted) list
c
	if(last_ptr .eq. 0) then
c
c Make new top, and link the rest under the new one (might be empty)
c
	  symbol.ptr_next = main_symbol.ptr_symbols
	  main_symbol.ptr_symbols = p_symbol
	else
c
c Link in the middle
c last_ptr is the pointer to a name smaller than ours
c so we need to link in between last_ptr and last_ptr.next (might be 0)
c                               
	  save_ptr = p_symbol		!save my pointer
	  p_symbol = last_ptr		!get last_ptr back
	  k = symbol.ptr_next		!save the next of last_ptr
	  symbol.ptr_next = save_ptr	!let that on point to me
	  p_symbol = save_ptr		!point to me again
	  symbol.ptr_next = k		!and set my forward (might be 0)
	endif
c
c Now we have p_symbol pointing to the correct name
c see if the level matches
c This symbol can be a just inserted one, or a alreay present one
c
20	main_symbol.rewrites = main_symbol.rewrites + 1
	symbol.rewrites      = symbol.rewrites + 1
c
	symbol.nk_name    = nk_name
	symbol.nk_ast     = nk_ast
	symbol.name       = name(1:nk_name)
c
	if((control.debug .and. debug_symbols) .ne. 0) then
	  call sys$fao('#symbol rewrites = !UL,',
     1           nk_deb1,debug_line(nk_deb+1:),
     1          %val(symbol.rewrites))
	  nk_deb = nk_deb + nk_deb1
	endif
c
c Now we have the symol name, see if can find the value for this level
c Level can be 
c   0 : Match the first (is the deepest)
c  n  : local symbol for level n
c
	p_symbol_value = symbol.ptr_values
	if(p_symbol_value .ne. 0) then
	  if(level .ne. 0) then
c
c We want a specific one, see if level matches
c
	    if(symbol_value.level .eq. level) goto 50
	  else
c
c Global one, the first match (will be the deepest level)
c
	    goto 50
	  endif
	endif
c
c Either no values yet, or the level is different
c Check if allowed
c
	if((iand(control.strict_mode,strict_declaration) .ne. 0) .and. 
     1       level .eq. 0) then
	  if(name(1:1) .ne. '$' .and. name(1:1) .ne. '%') then
	    istat= %loc(dix_msg_undecl)
	    err_arg = name
	    goto 90
	  endif
	endif
c
c so add a new value block in the chain
c 1. Allocate a new block
c
c If we have some in the cache, use it, else allocate a new one
c
	if((control.debug .and. debug_symbols) .ne. 0) then
	  call dix_append(nk_deb,debug_line,'Add new level,')
	endif
c
	if(main_symbol.ptr_spare_values .ne. 0) then
c
c We had one in the cache
c
	  p_symbol_value = main_symbol.ptr_spare_values
	  main_symbol.ptr_spare_values = symbol_value.ptr_next
	else
c
c Allocate a new one
c
	  call get_vm(control,sizeof(symbol_value),p_symbol_value,
     1             main_symbol.zone_symbol_value,.false.,'SYMBOLVALUE')
	  symbol_value.magic = magic_symbol_value
	  call dix_eval_init_value(symbol_value.value)
	endif
c
c link in, let this new block point to the previous (might be 0)
c
	symbol_value.ptr_next = symbol.ptr_values
	symbol.ptr_values       = p_symbol_value
c
c Init the symbol value block
c
	symbol_value.rewrites   = 0
	symbol_value.lookups    = 0
	symbol_value.link_back  = 0
	symbol_value.n_links    = 0
	symbol_value.ptr_symbol = p_symbol	!link back
c
	if(fixed .or. (iand(control.strict_mode,strict_typing) .ne. 0)) then
	  symbol_value.fixed_type = val.type
	else
	  symbol_value.fixed_type = symb_typ_none
	endif
c
c And set the level
c
	symbol_value.level  = level
	symbol_value.secure = secure
	goto 60
c
c Now we have a pointer to the correct value block
c Check if the types are the same (is the symbol has a fixed type)
c                    
50	if(symbol_value.fixed_type .ne. symb_typ_none) then
c
c Found Symbol has a fixed type, 
c
	  if(symbol_value.fixed_type .ne. val.type) then
	    istat = %loc(dix_msg_wrongtype)
	    err_arg = name
	    goto 90
	  endif
	endif
c
c Check if the symbol value is secured (e.g. control variable of a FOR statement)
c
	if(symbol_value.secure .ne. secure) then
	  istat = %loc(dix_msg_protected)
	  nk = dix_util_get_len(symbol_value.secure)
	  err_arg = name//'('//symbol_value.secure(1:nk)//')'
	  goto 90
	endif
c
c Now check if symbol is an alias
c
60	do while(symbol_value.link_back .ne. 0)
	  p_symbol_value = symbol_value.link_back
	end do
c
c All oke, now copy value
c 
	call  dix_eval_copy_value(val,symbol_value.value)
	symbol_value.rewrites   = symbol_value.rewrites + 1
	istat = 1
c
	if((control.debug .and. debug_symbols) .ne. 0) then
	  call sys$fao('#value rewrites = !UL',
     1           nk_deb1,debug_line(nk_deb+1:),
     1          %val(symbol_value.rewrites))
	  nk_deb = nk_deb + nk_deb1
c
c Output accumulated debug info
c
	  call dix_main_print_debug(control,debug_symbols,
     1                            debug_line(1:nk_deb))
	endif
	goto 90
c
c Uer tried to define a abbreviated symbol conflict
c
80	istat = %loc(dix_msg_absymd)
	err_arg = symb_name
c
90	dix_symbol_add_value    = istat
	return
	end
	function dix_symbol_find(control,symbolname,value)
	implicit none
c
c Find symbol 'symbolname', and return value block if found
c
	include 'dix_symbol.inc'
	record /control/ control	!:i: the control blovk
	character*(*) symbolname        !:i: symbol name
	record /value/ value		!:o: the value
	logical dix_symbol_find		!:f: functionr result
c#
	integer*4 context,nk,nk_symb,level,p_symb,nk_ast,nkd,fixed
	record /value/ val
	character*(max_symbol_name_length) symbname
	character*(max_line_length) line
c
	integer*4 dix_util_get_len
	logical dix_symbol_enumerate
c
	record /main_symbol/ main_symbol
	pointer (p_main_symbol,main_symbol)
c
	record /symbol/ symbol
	pointer (p_symbol,symbol)
c
	record /symbol_value/ symbol_value
	pointer (p_symbol_value,symbol_value)
c
c Assume not found
c
	dix_symbol_find = .false.
	p_main_symbol = control.p_symbols
c
c Get length of name
c
	nk = dix_util_get_len(symbolname)
c
	call dix_main_print_debug(control,debug_symbols,
     1           'Searching for '//symbolname(1:nk))
c
c Enumerate all symbs
c
	context = 0
	do while(dix_symbol_enumerate(control,val,symbname,nk_symb,
     1              context,.true.,level,p_symb,.false.,nk_ast,fixed))
c
c See if name matches (case_blind)
c
	  p_symbol = p_symb
	  if((control.debug .and. debug_symbols) .ne. 0) then
	    call sys$fao(' compare to !AS (max_len=!UL, min_len=!UL)',
     1                   nkd,line,symbname(1:nk_symb),
     1                   %val(nk_symb),%val(nk_ast))
	    call dix_main_print_debug(control,debug_symbols,line(1:nkd))
	  endif
	  if(nk .lt. nk_ast .or. nk .gt. nk_symb) goto 10
c
	  if(symbolname(1:nk) .eq. symbname(1:nk)) then
c
c Return value
c
	    call dix_main_print_debug(control,debug_symbols,
     1                               ' got match')
	    dix_symbol_find = .true.
	    main_symbol.lookups = main_symbol.lookups + 1	      
	    symbol.lookups = symbol.lookups + 1
c
	    p_symbol_value = symbol.ptr_values
	    symbol_value.lookups = symbol_value.lookups + 1
c
c Now check if the symbol is an alias
c
 	    if(symbol_value.link_back .ne. 0) then
c
c Find the orig
c
 	      do while(symbol_value.link_back .ne. 0)
	        p_symbol_value = symbol_value.link_back
	      end do
	      call dix_eval_copy_value(symbol_value.value,value)
	      symbol_value.lookups = symbol_value.lookups + 1
	      p_symbol = symbol_value.ptr_symbol
	      symbol.lookups = symbol.lookups + 1
	    else
	      call dix_eval_copy_value(symbol_value.value,value)
	    endif
	    goto 90
	  endif
10	end do
90	return
	end
	function dix_symbol_enumerate(control,value,symbname,nk_symb,
     1            context,specials,level,ptr,none_too,nk_ast,fixed)
	implicit none
c
c Return (per call) the next symbolname/value
c
	include 'dix_symbol.inc'
	record /control/ control	!:i: control structure	
	record /value/ value		!:o: symbol value
	character*(*) symbname		!:o: symbol name
	integer*4 nk_symb		!:o: length of symbolname
	integer*4 context		!:io: context (init to 0)
	logical specials		!:i: specials too?
	integer*4 level			!:o: level of symbol
	integer*4 ptr			!:o: Pointer to name
	logical none_too		!:i: return none symbols too?
	integer*4 nk_ast		!:o: length upto the asterix
	logical*4 fixed			!:i: fixed symbol?
	logical dix_symbol_enumerate	!:f: function result
	
c#
	record /main_symbol/ main_symbol
	pointer (p_main_symbol,main_symbol)
c
	record /symbol/ symbol
	pointer (p_symbol,symbol)
c
	record /symbol_value/ symbol_value
	pointer (p_symbol_value,symbol_value)
c
	record /level/ slevel
c
	p_main_symbol = control.p_symbols
c
	dix_symbol_enumerate = .false.
c
	if(context .eq. 0) then
	  p_symbol = main_symbol.ptr_symbols
	else
	  p_symbol = context
	endif
	if(context .eq. -1) goto 90
c
	do while(p_symbol .ne. 0)
c
c See if there is a value connected
c
	  if(symbol.ptr_values .ne. 0) then
c
c Yes, now  see if it is not the "none" symbol
c
	    p_symbol_value = symbol.ptr_values
	    if(none_too .or. symbol_value.value.type .ne. symb_typ_none) then
c
c No, now see if special, if not (or if special wanted) : gotit
c
	      if(specials .or. symbol.name(1:1) .ne. '%') then
c
c Now check for level (if strict.local) set
c
	        if(symbol.name(1:1) .eq. '%' .or. 
     1             symbol.name(1:1) .eq. '$') goto 20	!specials are oke
c
	        if(iand(control.strict_mode,strict_declaration_local)
     1                .ne. 0) then
c
c strict.local is set, return only symbols from this level
c
	          slevel.tval = symbol_value.level
	          if(control.depth .eq. slevel.depth) goto 20
	        else
c
c strict.local not set, all levels are ok.
c
	          goto 20 
	        endif
	      endif
	    endif
	  endif
	  p_symbol = symbol.ptr_next
	end do
c
c Not found,
c
	context = -1
	goto 90
c
c Now symbol points to the correct one
c
20	p_symbol_value = symbol.ptr_values
	call dix_eval_copy_value(symbol_value.value,value)
	level = symbol_value.level
	nk_symb  = symbol.nk_name
	symbname = symbol.name(1:nk_symb)
	nk_ast   = symbol.nk_ast
	fixed = symbol_value.fixed_type .ne. symb_typ_none
	ptr = p_symbol
	dix_symbol_enumerate = .true.
	context = symbol.ptr_next	!now point to the next
	if(context .eq. 0) context = -1	!signal eof
90	return
	end
	function dix_symbol_delete(control,mask,logit,specials,all)
	implicit none
c
c Delete a symbol
c
	include 'dix_symbol.inc'
	record /control/ control		!:i: control block
	character*(*) mask			!:i: the symbol name(mask)
	logical logit				!:i: log the deletion?
	logical specials			!:i: specials too?
	logical all				!:i: delete all levels?
	integer dix_symbol_delete		!:f: function result
c#
	integer*4 ndel,istat,k,l
c
	logical str$match_wild
	external dix_msg_symdel
	external dix_msg_nosymdel
c
	record /main_symbol/ main_symbol
	pointer (p_main_symbol,main_symbol)
c
	record /symbol/ symbol
	pointer (p_symbol,symbol)	
c
	record /symbol_value/ symbol_value
	pointer (p_symbol_value,symbol_value)	
c
	p_main_symbol = control.p_symbols
c
	p_symbol = main_symbol.ptr_symbols
	ndel = 0
	do while(p_symbol .ne. 0)
	  if(specials .or. 
     1       (symbol.name(1:1) .ne. '%' .and. 
     1        symbol.name(1:1) .ne. '$')) then
	    if(str$match_wild(symbol.name(1:symbol.nk_name),mask)) then
	      p_symbol_value = symbol.ptr_values
	      if(p_symbol_value .ne. 0) then	      
c
c Got it, now delete the first instance only, or (if all) delete all
c
	        if(logit) call dix_message(control,dix_msg_symdel,
     1            symbol.name(1:symbol.nk_name))
	        ndel = ndel + 1
34	        main_symbol.removes = main_symbol.removes + 1
	        symbol.ptr_values = symbol_value.ptr_next
	        call dix_eval_free_value(symbol_value.value)
c
c And hook it in on the spare value list
c
	        symbol_value.ptr_next = main_symbol.ptr_spare_values
	        main_symbol.ptr_spare_values = p_symbol_value
c
c Check if this value is an alias
c
	        if(symbol_value.link_back .ne. 0) then
	          k = p_symbol_value
	          p_symbol_value = symbol_value.link_back
	          symbol_value.n_links = symbol_value.n_links - 1
	          p_symbol_value = k
	        endif
c
	        if(all) then
	          p_symbol_value = symbol.ptr_values
	          if(p_symbol_value .ne. 0) goto 34
	        endif
	      endif
	      if(symbol.ptr_values .eq. 0) then 
c
c No more values, so Remove the symbol from the symbol list
c
	        if(main_symbol.ptr_symbols .eq. p_symbol) then
	          main_symbol.ptr_symbols = symbol.ptr_next
	        else
c
c Now get the previous symbol
c  (the one pointing to this one)
c
	          k = p_symbol		!remember it
	          l = symbol.ptr_next	!and its forward
	          p_symbol = main_symbol.ptr_symbols
	          do while(p_symbol .ne. 0)
	            if(symbol.ptr_next .eq. k) then
	              symbol.ptr_next = l		!so link out
	              p_symbol = k		!get out symbol back
	              goto 45
	            endif
	            p_symbol = symbol.ptr_next
	          enddo
	          write(*,*) 'Bugcheck on delete_symbol'
	          stop
	        endif
c
c Now link the symbol name in the spare name list
c
45	        k = symbol.ptr_next
	        symbol.ptr_next = main_symbol.ptr_spare_names
	        main_symbol.ptr_spare_names = p_symbol
	        p_symbol = k
	        goto 49
	      endif
	    endif
	  endif
48	  p_symbol = symbol.ptr_next
49	end do
	istat = 1
	if(ndel .eq. 0) istat = %loc(dix_msg_nosymdel)
	dix_symbol_delete = istat
	return
	end
	subroutine dix_symbol_type(value,name,nk_name,short,upper)
	implicit none
c
c  return type of symbol
c
	include 'dix_symbol.inc'
	record /value/ value		!:i: the value itself
	character*(*) name		!:o: the name
	integer*4 nk_name		!:o: the  length of name
	logical short			!:i: short format?
	logical upper			!:i: uppercase?
c#
	integer*4 dix_util_get_len
c
	if(value.type .eq. symb_typ_int) then
	  if(short) then
	    name = 'Int'
	  else
	    name = 'Integer'
	  endif
	elseif(value.type .eq. symb_typ_char) then
	  if(short) then
	    name = 'Char'
	  else
	    name = 'Character'
	  endif
	elseif(value.type .eq. symb_typ_real) then
	  name = 'Real'
	elseif(value.type .eq. symb_typ_log) then
	  if(short) then
	    name = 'Log'
	  else
	    name = 'Logical'
	  endif
	elseif(value.type .eq. symb_typ_date) then
	  name = 'Date'
	elseif(value.type .eq. symb_typ_decimal) then
	  if(short) then
	    name = 'Deci'
	  else
	    name = 'Decimal'
	  endif
	else
	  if(short) then
	    name = 'Unkn'
	  else
	    name = 'Unknown'
	  endif
	end if	
	nk_name = dix_util_get_len(name)
	if(upper) call str$upcase(name(1:nk_name),name(1:nk_name))
	return
	end
	subroutine dix_symbol_delete_level(control)
	implicit none
c
c Delete all symbols ofa specified level
c
	include 'dix_symbol.inc'
	record /control/ control		!:io: control structure
c#
	integer*4 dix_symbol_get_level
	integer*4 level,k,l
c
	record /main_symbol/ main_symbol
	pointer (p_main_symbol,main_symbol)
c
	record /symbol/ symbol
	pointer (p_symbol,symbol)	
c
	record /symbol_value/ symbol_value
	pointer (p_symbol_value,symbol_value)	
c
	p_main_symbol = control.p_symbols
	level = dix_symbol_get_level(control)
c
	p_symbol = main_symbol.ptr_symbols
	do while(p_symbol .ne. 0)
	  if(symbol.ptr_values .ne. 0) then
	    p_symbol_value = symbol.ptr_values
	    if(symbol_value.level .eq. level) then
	      call dix_eval_free_value(symbol_value.value)
c
c Oke , found one, so link out
c
	      symbol.ptr_values = symbol_value.ptr_next
c
c And link in in empty chain
c
	      main_symbol.removes = main_symbol.removes + 1
	      symbol_value.ptr_next = main_symbol.ptr_spare_values
	      main_symbol.ptr_spare_values = p_symbol_value
c
c If the symbol has a link to another, decrement it's link count
c
	      if(symbol_value.link_back .ne. 0) then
	        k = p_symbol_value
	        p_symbol_value = symbol_value.link_back
	        symbol_value.n_links = symbol_value.n_links - 1
	        p_symbol_value = k
	      endif
c
c If all values gone, delete this symbol
c
	      if(symbol.ptr_values .eq. 0) then 
c
c No more values, so Remove the symbol from the symbol list
c
	        if(main_symbol.ptr_symbols .eq. p_symbol) then
	           main_symbol.ptr_symbols = symbol.ptr_next
	        else
c
c Now get the previous symbol
c
	          k = p_symbol		!remember this address
	          l = symbol.ptr_next	!and its forward
	          p_symbol = main_symbol.ptr_symbols
	          do while(p_symbol .ne. 0)
	            if(symbol.ptr_next .eq. k) then
	              symbol.ptr_next = l		!so link out
	              p_symbol = k		!get out symbol back
	              goto 45
	            endif
	            p_symbol = symbol.ptr_next
	          enddo
	          write(*,*) 'Bugcheck in symbol_delete_level'
	          stop
	        endif
c
c Now link the symbol name in the spare name list
c
45	        k = symbol.ptr_next
	        symbol.ptr_next = main_symbol.ptr_spare_names
	        main_symbol.ptr_spare_names = p_symbol
	        p_symbol = k
	        goto 49
	      endif	!no more value blocks
	    endif	!level matches
	  endif		!has value blocks
48	  p_symbol = symbol.ptr_next
49	end do
	return
	end
	function dix_symbol_exists(control,symbolname)
	implicit none
c
c Return true is symbol exists at level level
c
	include 'dix_symbol.inc'
	record /control/ control		!:i: control block
	character*(*) symbolname		!:i: symbol name
	logical dix_symbol_exists		!:f: function result
c#
	integer*4 context,nk,nk_symb,level_fnd,level,p_symb,nk_ast
	logical*4 fixed
	record /value/ val
	character*(max_symbol_name_length) symbname
c
	integer*4 dix_util_get_len
	logical dix_symbol_enumerate
	integer*4 dix_symbol_get_level
c
	record /main_symbol/ main_symbol
	pointer (p_main_symbol,main_symbol)
c
	record /symbol/ symbol
	pointer (p_symbol,symbol)
c
	record /symbol_value/ symbol_value
	pointer (p_symbol_value,symbol_value)
c
c Assume not found
c
	dix_symbol_exists = .false.
	p_main_symbol = control.p_symbols
	level = dix_symbol_get_level(control)
c
	call dix_eval_init_value(val)
	nk = dix_util_get_len(symbolname)
c
c Enumerate all symbs
c
	context = 0
	do while(dix_symbol_enumerate(control,val,symbname,nk_symb,
     1              context,.true.,level_fnd,p_symb,.false.,
     1              nk_ast,fixed))
c
c if name matches
c
	  p_symbol = p_symb
	  if(nk .gt. nk_symb) goto 10
	  if(nk .lt. nk_ast ) goto 10
	  if(symbolname(1:nk) .eq. symbname(1:nk)) then
c
c See if level equal
c
	    main_symbol.lookups = main_symbol.lookups + 1
	    symbol.lookups = symbol.lookups + 1
	    p_symbol_value = symbol.ptr_values
	    symbol_value.lookups = symbol_value.lookups + 1
	    dix_symbol_exists = level_fnd .eq. level
	    goto 90
	  endif
10	end do
90	call dix_eval_free_value(val)
	return
	end
	function dix_symbol_get_level(control)
	implicit none
c
c Get current level
c
	include 'dix_symbol.inc'
	record /control/ control		!:i: control structure
	integer*4 dix_symbol_get_level		!:f: the level
c#
	record /level/ level
c
	level.depth = control.depth
	call dix_inter_get_struct_level(control,level.struct_level)
	dix_symbol_get_level = level.tval
	return
	end
	function dix_symbol_hash(name)
	implicit none
c
c Make a hash for the symbolname
c
	character*(*) name	!:i: the name of the symbol
	byte dix_symbol_hash	!:o: the hash value
c#
	integer*4 k
	byte res
c
	res = 0
	do k=1,len(name)
	  res = res .xor. ichar(name(k:k))
	end do
	dix_symbol_hash = res
	return
	end
	subroutine dix_symbol_statistics(control,full,all)
	implicit none
c
c Print symbol statistics
c
	include 'dix_symbol.inc'
	record /control/ control		!:i: the control structure
	logical full				!:f: full format?
	logical all				!:i: all wanted
c#
	record /main_symbol/ main_symbol
	pointer (p_main_symbol,main_symbol)
c
	record /symbol/ symbol
	pointer (p_symbol,symbol)
c
	record /symbol_value/ symbol_value
	pointer (p_symbol_value,symbol_value)
c
	character*(max_short_line_length) levelasc
	integer*4 nk_level
c
	character*(max_line_length) line,line1,line2
	character*(max_short_line_length) typasc
	integer*4 nk,n_symb,n_val,nk1,ntv,ntl,ntr,nk2,nk_typ
	logical dix_dump_print_line
c
	character*(*) fao_string
	parameter (fao_string = '!20AS = !10UL  ')
c
	p_main_symbol = control.p_symbols
c
c Print general info
c
	call sys$fao(fao_string//fao_string,nk,line,
     1             '#Inserts',%val(main_symbol.enters),
     1             '#Removes',%val(main_symbol.removes))
	if(.not. dix_dump_print_line(control,0,line(1:nk))) goto 90
	call sys$fao(fao_string//fao_string,nk,line,
     1             '#Rewrites',%val(main_symbol.rewrites),
     1             '#Lookups',%val(main_symbol.lookups))
	if(.not. dix_dump_print_line(control,0,line(1:nk))) goto 90
c
	p_symbol = main_symbol.ptr_spare_names
	n_symb = 0
	do while(p_symbol .ne. 0) 
	  n_symb = n_symb + 1
	  p_symbol = symbol.ptr_next
	end do	  
c
	p_symbol_value = main_symbol.ptr_spare_values
	n_val  = 0
	do while(p_symbol_value .ne. 0)
	  n_val = n_val + 1
	  p_symbol_value = symbol_value.ptr_next
	end do
c
	call sys$fao(fao_string//fao_string,nk,line,
     1       '#Deleted names',%val(n_symb),
     1       '#Deleted values',%val(n_val))
	if(.not. dix_dump_print_line(control,0,line(1:nk))) goto 90
c
c Now print the symbols (total if not full)
c
	p_symbol = main_symbol.ptr_symbols
	n_symb = 0
	n_val  = 0
	if(full) then
	  line1         = ' #vals'
	  if(all) line1 = 'Level     '
	  typasc = 'Type'
	  call sys$fao('!#AS !AS !6AS !6AS !6AS !AS',nk,line,
     1        %val(max_symbol_name_length),
     1        %Descr('Symbol name'),
     1        typasc,
     1        line1(1:6),
     1        %descr(' #Mods'),
     1        %descr('#Finds'),
     1        %descr('Value'))
	  if(.not. dix_dump_print_line(control,0,line(1:nk))) goto 90
	endif
	ntl = 0
	ntr = 0
	ntv = 0
	do while(p_symbol .ne. 0)
	  if(symbol.ptr_values .ne. 0) then	  
	    n_symb = n_symb + 1
	    n_val = 0
	    line1 = symbol.name(1:symbol.nk_name)
	    nk1 = symbol.nk_name
	    p_symbol_value = symbol.ptr_values
	    do while(p_symbol_value .ne. 0)
	      n_val = n_val + 1
	      if(full .and. all) then
	        call dix_symbol_levelasc(symbol_value.level,levelasc,nk_level)
	        call dix_symbol_type(symbol_value.value,typasc,nk_typ,
     1                .true.,.false.)
	        if(symbol_value.fixed_type .ne. 0) then
	          typasc(nk_typ+1:) = ':FIX'
	        endif
	        call sys$fao('!#AS !AS !6AS !6UL !6UL',nk,line,
     1            %val(max_symbol_name_length),
     1            line1(1:nk1),
     1            typasc,
     1            levelasc(1:nk_level),
     1            %val(symbol_value.rewrites),
     1            %val(symbol_value.lookups))
	        call dix_con_value_intasc(control,symbol_value.value,
     1               line1,nk1,des_flag_translate_nor)
	        if(.not. dix_dump_print_line(control,0,
     1           line(1:nk)//' '//line1(1:nk1))) goto 90
	        nk1 = 0
	      endif
	      p_symbol_value = symbol_value.ptr_next
	    end do
	    ntl = ntl + symbol.lookups
	    ntr = ntr + symbol.rewrites
	    ntv = ntv + n_val
	    if(full .and. .not. all) then
	      p_symbol_value = symbol.ptr_values
	      call dix_con_value_intasc(control,symbol_value.value,
     1               line1,nk1,des_flag_translate_nor)
	      call dix_symbol_type(symbol_value.value,typasc,nk_typ,
     1               .true.,.false.)
	      if(symbol_value.fixed_type .ne. 0) then
	        typasc(nk_typ+1:) = ':FIX'
	      endif
	      call sys$fao('!#AS !AS !6UL !6UL !6UL',nk,line,
     1          %val(max_symbol_name_length),
     1          symbol.name(1:symbol.nk_name),
     1          typasc,
     1          %val(n_val),
     1          %val(symbol.rewrites),
     1          %val(symbol.lookups))
	      if(.not. dix_dump_print_line(control,0,
     1             line(1:nk)//' '//line1(1:nk1))) goto 90
	    endif
	  endif
	  p_symbol = symbol.ptr_next
	end do
	if(.not. full) then
	  call sys$fao(fao_string//fao_string,nk,line,
     1         '#Symbols',%val(n_symb),
     1         '#Symbol values',%val(ntv))
	  if(.not. dix_dump_print_line(control,0,line(1:nk))) goto 90
	else
	  call sys$fao('Total(!UL symbols)',nk1,line1,%val(n_symb))
	  line2 = ' '
	  typasc = ' '
	  if(.not. all) call sys$fao('!6UL',nk2,line2,%val(ntv))
	  call sys$fao('!#AS !AS !6AS !6UL !6UL',nk,line,
     1        %val(max_symbol_name_length),
     1        line1(1:nk1),
     1        typasc,
     1        line2(1:nk2),
     1        %val(ntr),
     1        %val(ntl))
	  if(.not. dix_dump_print_line(control,0,line(1:nk))) goto 90
	endif
c
90	return
	end
	subroutine dix_symbol_default(control,val)
	implicit none
c
c Init a symbol to a default value
c
	include 'dix_def.inc'
	record /control/ control
	record /value/ val		!:io: symbol value
c#
	if(val.type .eq. symb_typ_int)  then
	  val.ival = 0	
	  val.i8val(2) = 0
	endif
	if(val.type .eq. symb_typ_log)  val.lval = .false.
	if(val.type .eq. symb_typ_real) then
	  if(control.real_size .eq. 8) then
	    val.rval8 = 0.0	
	  elseif(control.real_size .eq. 8) then
	    val.rval16 = 0.0	
	  else
	    val.rval = 0.0	
	  endif
	endif
	if(val.type .eq. symb_typ_char) call dix_eval_init_value(val)
	if(val.type .eq. symb_typ_date) then
	   val.date(1) = 0
	   val.date(2) = 0
	endif
	return
	end
	function dix_symbol_set_alias(control,name1,name2,err_arg)
	implicit none
c
c Set name1 to be an alias of name2
c so every change to name2 will be done to name1 instead
c
	include 'dix_symbol.inc'
	record /control/ control		!:i: control structure
	character*(*) name1			!:i: the name to be aliassed
	character*(*) name2			!:i: the name of the alias
	character*(*) err_arg			!:o: error argument(if error)
	integer*4 dix_symbol_set_alias		!:f: function result
c#
	integer*4 istat
c
	record /main_symbol/ main_symbol
	pointer (p_main_symbol,main_symbol)
c
	record /symbol/ symbol
	pointer (p_symbol,symbol)
c
	record /symbol_value/ symbol_value1
	pointer (p_symbol_value1,symbol_value1)
c
	record /symbol_value/ symbol_value2
	pointer (p_symbol_value2,symbol_value2)
c
	external dix_msg_symbnotf
c
	p_main_symbol = control.p_symbols
c
c First try to find name1
c
	p_symbol = main_symbol.ptr_symbols
	do while(p_symbol .ne. 0)
	  if(symbol.name(1:symbol.nk_name) .eq. name1) then
c
c Now got the symbol to be aliassed
c
	    p_symbol_value1 = symbol.ptr_values
	    goto 10
	  endif
	  p_symbol = symbol.ptr_next
	end do
	err_arg = name1
	goto 80
c
c Now try to find name2
c
10	p_symbol = main_symbol.ptr_symbols
	do while(p_symbol .ne. 0)
	  if(symbol.name(1:symbol.nk_name) .eq. name2) then
c
c Now got the symbol to be aliassed
c
	    p_symbol_value2 = symbol.ptr_values
	    goto 50
	  endif
	  p_symbol = symbol.ptr_next
	end do
	err_arg = name2
	goto 80
c
c Now symbol_value1 contains the name to be aliassed
c     symbol_value2 contains the name of the alias
c
50	symbol_value2.link_back = p_symbol_value1
	symbol_value1.n_links   = symbol_value1.n_links + 1
	symbol_value2.value     = symbol_value1.value
	istat = 1
	goto 90
80	istat = %loc(dix_msg_symbnotf)	
90	dix_symbol_set_alias = istat
	return
	end
	subroutine dix_symbol_levelasc(level,line,nk)
	implicit none
c
c Make an ascii representation of the symbol level
c
	include 'dix_symbol.inc'
c
	record /level/ level		!:i: level
	character*(*) line		!:o: the ascii form
	integer*4 nk			!:o: length of line
c#
	nk = 0
	call sys$fao('!UL.!UL',nk,line,
     1         %val(level.depth),
     1         %val(level.struct_level))
	return
	end
	subroutine dix_symbol_show_vm(control,fi)
	implicit none
c
c SHow VM used for Symbols
c
	include 'dix_symbol.inc'
	record /control/ control	!:i: control structure
	logical fi			!:i: flag
c#
	record /main_symbol/ main_symbol
	pointer (p_main_symbol,main_symbol) 
c
	p_main_symbol = control.p_symbols
	call dix_util_show_vm1(control,main_symbol.zone_symbol,fi,0)
	call dix_util_show_vm1(control,main_symbol.zone_symbol_value,fi,0)
	return
	end
	subroutine dix_symbol_change_real_size(control,old,new)
	implicit none
c
	include 'dix_symbol.inc'
	record /control/ control
	integer*4 old
	integer*4 new
c
	record /main_symbol/ main_symbol
	pointer (p_main_symbol,main_symbol) 
c
	record /symbol/ symbol
	pointer (p_symbol,symbol)
c
	record /symbol_value/ symbol_value
	pointer (p_symbol_value,symbol_value)
c
	integer*4 old_type,new_type
	logical overflow
c
	external dix_msg_symbreov
c
	p_main_symbol = control.p_symbols
c
	p_symbol = main_symbol.ptr_symbols
	call dix_con_cvt_float_type(control,old,old_type)
	call dix_con_cvt_float_type(control,new,new_type)
	do while(p_symbol .ne. 0)
	  p_symbol_value = symbol.ptr_values
	  do while(p_symbol_value .ne. 0) 
	    if(symbol_value.value.type .eq. symb_typ_real) then
c
c Convert the reals
c
	      call dix_con_cvt_float(control,
     1            symbol_value.value.rval,old_type,
     1            symbol_value.value.rval,new_type,overflow)
	      if(overflow) call dix_message(control,dix_msg_symbreov,
     1            symbol.name(1:symbol.nk_name))
	    endif
	    p_symbol_value = symbol_value.ptr_next
	  enddo
	  p_symbol = symbol.ptr_next
	end do
	return
	end
c
        function dix_symbol_get_symbol(name,symb,nk_symb)
        implicit none
c
c Get a symbol from the cli. If present check the syntax
c
        character*(*) name      !:i: the CLI name
        character*(*) symb      !:o: the value
        integer*4 nk_symb       !:o: the length of the symbol
        integer*4 dix_symbol_get_symbol     !:f: function result
c#
        integer*4 istat
        integer*4 dix_util_check_name
c
        istat = 1
        nk_symb = 0
        call cli$get_value(name,symb,nk_symb)
        if(nk_symb .gt. 0) then
          istat = dix_util_check_name(symb(1:nk_symb))
        else
          istat = 1
        endif
        dix_symbol_get_symbol = istat
        return
        end
