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