subroutine dix_des_remove(control,des_info) implicit none include 'dix_def.inc' c record /control/ control record /des_info/ des_info !:io: descriptor entry C# c c We should close open luns for user defined types c call dix_main_print_debug(control,debug_des, 1 'Removing des_info '//des_info.fnam(1:des_info.nk_fnam)) c if(des_info.table_nor.count .gt. 0) then call dix_des_close_user_luns(control, 1 des_info.table_nor.count, 1 %val(des_info.table_nor.address)) endif if(des_info.table_vfc.count .gt. 0) then call dix_des_close_user_luns(control, 1 des_info.table_vfc.count, 1 %val(des_info.table_vfc.address)) endif c if(des_info.zone_file.zone .ne. 0) then call delete_vm(control,des_info.zone_file) end if c call dix_des_init_des(des_info) return end subroutine dix_des_close_user_luns(control,n_des,des) implicit none c include 'dix_def.inc' record /control/ control !:i: control block integer*4 n_des !:i: ndescriptor record /des_rec_fil/ des(*) !:i: des records c# integer*4 k c do k=1,n_des if(des(k).lun_translate .ne. 0) then call memtab_close(control,des(k).lun_translate) endif end do return end subroutine dix_des_init_des(des_info) implicit none c c init des record c include 'dix_def.inc' c record /des_info/ des_info !:o: des record c# des_info.fnam = ' ' des_info.nk_fnam = 0 c call dix_util_init_table(des_info.table_nor,0) call dix_util_init_table(des_info.table_vfc,0) call dix_util_init_table(des_info.parameters,0) des_info.first_nor_var = 0 des_info.first_vfc_var = 0 c des_info.fixed = .true. des_info.has_fields = .false. c des_info.usage_count = 0 des_info.lun_memtab = 0 c des_info.zone_file.zone = 0 c return end function dix_des_get_all(control,file,fnam,signal,all) implicit none c c Try to get a description file/module c First try a file with extension .des in the same directory as the file c Then try to open the file in the current diectory c then try to find in dex_des.tlb c include 'dix_def.inc' record /control/ control record /file_info/ file !:io: current file to hook into character*(*) fnam !:i: explicit filename for description ! may be blank logical*4 signal !:i: signal errors ? logical*4 all !:i: include all matches? logical*4 dix_des_get_all !:f: get all matching descriptions c# include '($jpidef)' c logical dix_util_file_parse integer*4 dix_lbr_add_des logical dix_des_get_des_file c integer*4 lun,bpos,epos,nk_Wfnam,old_cur_file,k character*(max_line_length) wfnam,save_file,save_file1 integer*4 dix_util_get_len_fu c c make sure 'file' is the current c old_cur_file = control.cur_file control.cur_file = %loc(file) c c First kill old data c dix_des_get_all = .false. call lib$get_lun(lun) c c wfnam = fnam nk_wfnam = dix_util_get_len_fu(fnam) c c Try to find an extension, if not present add a .DES c this prevents a problem when the original filename c is pointed to by a logical (as sysuaf) c call dix_util_file_parse(wfnam,'T',bpos,epos) if(bpos .eq. 0) then wfnam(nk_wfnam+1:) = '.DES' nk_wfnam = nk_wfnam + 4 endif c c Get the name part of the file c bpos is the start of the name, epos the end of the type c call dix_util_file_parse(file.fnam,'N',bpos,k) call dix_util_file_parse(file.fnam,'T',k,epos) c c Try to open in current directory, take the c filename part from the source file c open(lun, 1 file=wfnam(1:nk_wfnam), 1 defaultfile=file.fnam(bpos:epos), 1 status='old', 1 err=30,shared,readonly) c c Make sure the description file name <> the datafilename c inquire(lun,name=save_file) if(save_file .eq. file.fnam) then close(lun) else c c Got a file, copy to memtab, close lun and process lines c if(dix_des_get_des_file(control,lun, 1 file,signal)) dix_des_get_all = .true. c c If the read is successfull, and not all wanted, stop now c if(dix_des_get_all .and. .not. all) goto 90 endif c c Try to open .des file in same directory as datafile c Now take as default the total filename upto the type c 30 open(lun, 1 file=wfnam(1:nk_wfnam), 1 defaultfile=file.fnam(1:epos), 1 status='old', 1 err=40,shared,readonly) inquire(lun,name=save_file1) c c If we already have the file c if(save_file1 .eq. file.fnam .or. save_file1 .eq. save_file) then close(lun) else c c GEt the description c if(dix_des_get_des_file(control,lun, 1 file,signal)) dix_des_get_all = .true. c c If the read is successfull, and not all wanted, stop now c if(dix_des_get_all .and. .not. all) goto 90 endif c c See if module can be lookup up in DIX_DES.TLB (either user of systemwide) c first by the name of the file c 40 if(control.nk_syslib .ne. 0 .or. control.nk_userlib .ne. 0) then wfnam = fnam if(wfnam .eq. ' ') wfnam = file.fnam if(dix_lbr_add_des(control,file,wfnam,signal,all)) 1 dix_des_get_all = .true. endif 90 call lib$free_lun(lun) c c If no descriptor yet, make the top the current (if it is there) c if(file.cur_des .eq. 0) file.cur_des = file.top_des c c Restore the old current file c control.cur_file = old_cur_file return end function dix_des_get_des_file(control,lun,file,signal) implicit none c c Read descriptor from file c include 'dix_def.inc' record /control/ control !:i: control structure integer*4 lun !:i: lun on which file is open record /file_info/ file !:i: file info record logical signal !:i: signal errors? logical dix_des_get_des_file !:f: result c# integer*4 nlines,err_row,nk_fnam,ptr,istat character*(max_line_length) fnam logical master_link c integer*4 dix_util_get_len_fu integer*4 dix_des_read_it logical dix_des_find_des external dix_msg_alrload external dix_msg_desadd logical dix_des_find_des_file c record /des_info/ des_info pointer (p_des_info,des_info) c dix_des_get_des_file = .false. c inquire(lun,name=fnam) nk_fnam = dix_util_get_len_fu(fnam) c c See if module already in file list c if(dix_des_find_des_file(file, 1 fnam(1:nk_fnam),des_in_file)) then call dix_message(control,dix_msg_alrload,fnam(1:nk_fnam)) else c c No, see if already open c if(dix_des_find_des(control,fnam(1:nk_fnam),des_in_file,ptr)) then p_des_info = ptr istat = 1 master_link = .false. else c c Copy the file to a memtab structure c c c Allocate a new description, and init it c call get_vm(control,sizeof(des_info),p_des_info, 1 control.zone_descr,.false.,'DES_INFO') des_info.magic = magic_des_info call dix_des_init_des(des_info) call memtab_open_lun(control,lun,des_info.lun_memtab,nlines) des_info.fnam = fnam des_info.nk_fnam = nk_fnam des_info.in_library = des_in_file c c Try to process the file c istat = dix_des_read_it(control,des_info.lun_memtab, 1 des_info,err_row) call memtab_close(control,des_info.lun_memtab) master_link = .true. endif if(istat) then c c Success , link it it in the file list c if(signal) call dix_message(control,dix_msg_desadd,fnam(1:nk_fnam)) call dix_des_link_in(control,file,des_info,master_link,.true.) dix_des_get_des_file = .true. else c c Failure, delete the des_structure c call free_vm(control,sizeof(des_info), 1 p_des_info,control.zone_descr) endif c c And close all things c endif close(lun) return end subroutine dix_des_link_in(control,file,des_info, 1 master_link,file_link) implicit none c c Link description in to two lists c a. the list of all opened descriptions (via control.top_descr) c b. the list of all descriptions for this file (file.top_des) c include 'dix_def.inc' record /control/ control !:i: control record record /file_info/ file !:i: file record to link des into record /des_info/ des_info !:i: des record to be linked logical master_link !:i: link into master chain? logical file_link !:i: link into file chain? c# record /des_expanded/ des_expanded pointer (p_des_expanded, des_expanded) c record /des_rec/ des_rec c c Get a link record for the total list c if(master_link) then call dix_util_link_in(des_info.link,control.top_descr) endif c c Get a link record for the file link, c if(file_link) then call get_vm(control,sizeof(des_expanded),p_des_expanded, 1 control.zone_links,.false.,'DES_EXPANDED') des_expanded.magic = magic_des_expanded c c Make unique handle name c call dix_des_make_handle(des_info,file.top_des,des_expanded) c c Link in to the chain of descriptions for this file c call dix_util_link_in(des_expanded.link,file.top_des) c c Init a vm_zone fior this descriptoin c the expanded names, and the des_recs will be allocated from this zone c call init_vm(control,des_expanded.zone_rec,0, 1 'EXP_'//des_expanded.handle(1:des_expanded.nk_handle), 1 .false.) c c des_expanded.p_des_info = %loc(des_info) call dix_util_init_table(des_expanded.table_nor,sizeof(des_rec)) call dix_util_init_table(des_expanded.fieldnames_nor,0) call dix_util_init_table(des_expanded.table_vfc,sizeof(des_rec)) call dix_util_init_table(des_expanded.fieldnames_vfc,0) c des_expanded.max_name_size = 0 des_expanded.nfield_total = 0 des_expanded.nfield_notcompressed = 0 c des_expanded.vfc_max_name_size = 0 des_expanded.vfc_nfield_total = 0 des_expanded.vfc_nfield_notcompressed = 0 c des_expanded.is_Expanded = .false. des_expanded.expand_error= .false. c if((control.debug .and. debug_expand) .ne. 0) then call dix_main_print_debug(control,debug_expand, 1 'Clearing expand flag for '// 1 des_expanded.handle(1:des_expanded.nk_handle)) endif c des_info.usage_count = des_info.usage_count + 1 endif c return end subroutine dix_des_link_out(control,file,des_expanded) implicit none c c Link description out of two lists c a. the list of all opened descriptions (via control.top_descr) c b. the list of all descriptions for this file (file.top_des) c include 'dix_def.inc' record /control/ control !:i: control record record /des_expanded/ des_expanded !:i: linked list structure record /file_info/ file !:io: file structure to remove it from c# record /des_info/ des_info pointer (p_des_info,des_info) c c Free from the file link c call dix_util_link_out(des_expanded.link,file.top_des) p_des_info = des_expanded.p_des_info c call dix_main_print_debug(control,debug_des, 1 'remove des_exp '//des_expanded.handle) c des_info.usage_count = des_info.usage_count - 1 if(des_info.usage_count .eq. 0) then c c All refs to this description are lost, now c linkout of total list, and remove c p_des_info = control.top_descr do while(p_des_info .ne. des_expanded.p_des_info) p_des_info = des_info.link.forw end do c c Yes is it the same c call dix_util_link_out(des_info.link,control.top_descr) call dix_des_remove(control,des_info) call free_vm(control,sizeof(des_info), 1 %loc(des_info),control.zone_descr) endif c c Free the vm_zone c if(des_expanded.zone_rec.zone .ne. 0) then call delete_vm(control,des_expanded.zone_rec) endif c c And remove the linked_list block c call free_vm(control,sizeof(des_expanded),%loc(des_expanded), 1 control.zone_links) return end function dix_des_reget(control,des_info) implicit none c c Reread a a description file/module c include 'dix_def.inc' record /control/ control !:i: control structure record /des_info/ des_info !:io: description record integer*4 dix_des_reget !:f: functoin result c# integer*4 lun_memtab,istat,nlines,err_row c integer*4 dix_lbr_get_module integer*4 dix_des_read_it integer*4 memtab_open c if(des_info.in_library .ne. des_in_file) then istat = dix_lbr_get_module(control,des_info.fnam,lun_memtab, 1 nlines,des_info.in_library) else istat = memtab_open(control,des_info.fnam,lun_memtab,nlines) endif if(istat) then istat = dix_des_read_it(control,lun_memtab,des_info,err_row) endif call memtab_close(control,lun_memtab) dix_des_reget = istat return end function dix_des_read_it(control,p_memtab,des_info,err_linenr) implicit none c c Process the .DES file c include 'dix_def.inc' c record /control/ control integer*4 p_memtab !:i: the lun on which the .DES file is open record /des_info/ des_info !:io:Des info integer*4 err_linenr !:o: of error,this contains the linenr logical*4 dix_des_read_it !:F: funciton result c# logical*4 dix_des_process_lines external dix_msg_syntax c record /des_rec_fil/ des_rec_fil record /param/ parameter c record /file_info/ file pointer (p_file,file) record /des_expanded/ des_expanded c integer*4 istat,p_usertypes,old_ll c c Make sure this des is the current of the current file c so the eval_expre in the process lines gets the correct paramters c call dix_main_print_debug(control,debug_des, 1 'Loading descr for '//des_info.fnam(1:des_info.nk_fnam)) des_expanded.link.forw = 0 des_expanded.link.backw = 0 des_expanded.p_des_info = %loc(des_info) c p_file = control.cur_file old_ll = file.cur_des file.cur_des = %loc(des_expanded) c call memtab_rewind(p_memtab) !rewind the file c call init_vm(control,des_info.zone_file,0, 1 'FIL_'//des_info.fnam(1:des_info.nk_fnam),.false.) call memtab_init(control,p_usertypes,'USER_TYPES') call dix_des_get_usertypes(control,p_memtab,p_usertypes) c call memtab_rewind(p_memtab) !rewind the file c call dix_util_init_table(des_info.table_nor,sizeof(des_rec_fil)) call dix_util_init_table(des_info.table_vfc,sizeof(des_rec_fil)) call dix_util_init_table(des_info.parameters,sizeof(parameter)) c c Phase 2 ; now fill in all data c istat = dix_des_process_lines(control,p_memtab, 1 des_info.table_nor,des_info.first_nor_var, 1 des_info.table_vfc,des_info.first_vfc_var, 1 des_info.fixed,des_info.has_fields, 1 des_info.parameters, 1 des_info.zone_file,err_linenr, 1 p_usertypes) c c Always add two entries to the vfc table c call dix_util_insert_table(control, 1 des_info.table_vfc,des_rec_fil,2, 1 des_info.zone_file,'VFC_DES_REC') call dix_util_insert_table(control, 1 des_info.table_vfc,des_rec_fil,2, 1 des_info.zone_file,'VFC_DES_REC') des_info.table_vfc.count = des_info.table_vfc.count-2 c call memtab_close(control,p_usertypes) if(.not. istat) then call dix_message(control,dix_msg_syntax, 1 des_info.fnam(1:des_info.nk_fnam)) endif c c restore old current des in the file c file.cur_des = old_ll c dix_des_read_it = istat return end subroutine dix_des_get_usertypes(control,p_memtab,p_usertypes) implicit none c c search the descriptor file for userdefined type c they begin with type name c and end with endtype c include 'dix_def.inc' record /control/ control!:i: control structure integer*4 p_memtab !:i: the liun for the descriptor integer*4 p_usertypes !:i: the lun for the usertypes c# character*(max_line_length) line character*(max_label_length) label integer*4 nk,p_line logical in_type c logical memtab_read logical dix_des_is_type c external dix_msg_openusrt c in_type = .false. label = ' ' do while(memtab_read(p_memtab,nk,line)) if(.not. in_type) then if(dix_des_is_type(line(1:nk),.true.,label)) then in_type = .true. endif endif if(in_type) then call memtab_add_record(control,p_usertypes,line(1:nk)) if(label .ne. ' ') then call memtab_get_line_ptr(p_usertypes,p_line) call memtab_add_label(control,p_usertypes,p_line,label,0) label = ' ' endif endif if(in_type) then if(dix_des_is_type(line(1:nk),.false.,label)) then in_type = .false. endif endif end do if(in_type) call dix_message(control,dix_msg_openusrt) return end function dix_des_is_type(line,start,label) implicit none c c Check to see if line is a #TYPE or #ENDTYPE statement c include 'dix_def.inc' c character*(*) line !:i: line to be checked logical start !:i: check for type or endtype character*(*) label !:o: label found on start logical dix_des_is_type !:f: true if (end)type statement found c# integer*4 ipos,nkar c character*(max_line_length) wline c dix_des_is_type = .false. c nkar = min(len(line),len(wline)) wline(1:nkar) = line(1:nkar) call dix_util_decent_line(nkar,wline(:nkar)) ipos = index(wline(1:nkar),'!') if(ipos .ne. 0) nkar = ipos-1 c if(nkar .gt. 0) then c c Find the verb c ipos = index(wline(1:nkar),' ') if(ipos .eq. 0) ipos = nkar+1 if(start) then c c Check if verb = #TYPE c dix_des_is_type = wline(1:ipos-1) .eq. '#TYPE' label = wline(ipos+1:nkar) else c c Check if type = #ENDTYPE c if(wline(1:ipos-1) .eq. 'END') then wline = wline(1:3)//wline(5:nkar) nkar = nkar - 1 ipos = index(wline(1:nkar),' ') if(ipos .eq. 0) ipos = nkar+1 endif dix_des_is_type = wline(1:ipos-1) .eq. '#ENDTYPE' endif endif return end function dix_des_process_lines(control,p_memtab, 1 table_nor,first_nor_var, 1 table_vfc,first_vfc_var, 1 fixed,has_fields, 1 parameters,vm_zone,err_linenr, 1 p_usertypes) implicit none c c Read all description line, and process them in some data structures c 1. des_recs, the parsed field-description lines c 2. par_adr , the parameter statements from the .des record c include 'dix_def.inc' record /control/ control !:i: control structure integer*4 p_memtab !:i: lun for description file c c Normal entries c record /table/ table_nor !:io: table for normal descriptions integer*4 first_nor_var !:o: first variable for vfc record /table/ table_vfc !:io: table for vfc descriptions integer*4 first_vfc_var !:o: first variable for vfc c logical*4 fixed !:o: set false if v(l)string found logical*4 has_fields !:o: set true if Bit fields present record /table/ parameters record /vm_zone/ vm_zone !:i: vm zone id integer*4 err_linenr !:o: if problem, this contains the linenr integer*4 p_usertypes !:i: the lun for the usertypes logical*4 dix_des_process_lines !:f: the function result c# c local vars c character*(max_label_length) username character*(max_err_arg_length) errline character*(max_line_length) range_data character*(max_line_length) TYP,ntyp,line1 character*(max_command_length) line,oline character*(max_line_length) size_asc,limit_value c integer*4 size,nkar,k,ipos,nk,jpos,min_val,max_val,nk1 integer*4 ent_type,kk,nkar1,nbr,istat,p_link_rec integer*4 nb_reserved,default_size,nke,nk_nam,lun_user integer*4 nk_limit_value,nk_size_asc,deep_if,n_des_rec_fils logical*4 field_mode,got_dimension,skip,field_ok,known logical*4 is_variable,in_range,is_vfc,zero_fill,exponent,fraction logical*4 no_display,user,has_pointer_vfc,has_pointer_nor logical*4 readonly,relative,leftjust,force_var integer*4 case,trans_override,is_filler c record /param/ param_rec c record /des_rec_fil/ des_rec_fil record /des_rec_fil/ des_rec_fils(*) pointer (p_des_rec_fils,des_rec_fils) c logical*4 dix_des_conv_idx integer*4 dix_util_find_char_bracket integer*4 dix_util_get_len_fu logical*4 dix_eval_check logical*4 dix_eval_express_int integer*4 dix_util_get_len integer*4 dix_des_get_range integer dix_util_check_name integer*4 memtab_read logical dix_util_remove_comment integer*4 dix_des_get_qualifier logical dix_inter_read_command_usertype logical*4 dix_des_is_type integer*4 dix_con_check_field_size logical*4 dix_des_correct_pointer c external dix_msg_dimerr external dix_msg_doubldef external dix_msg_endufoll external dix_msg_errdepen external dix_msg_errinline external dix_msg_general external dix_msg_invqual external dix_msg_invrange external dix_msg_mapfoll external dix_msg_maxstrdep external dix_msg_maxunidep external dix_msg_nestbitf external dix_msg_nestrange external dix_msg_nobitf external dix_msg_nomap external dix_msg_norangs external dix_msg_norange external dix_msg_nostruct external dix_msg_nounion external dix_msg_openbitf external dix_msg_openmap external dix_msg_openquote external dix_msg_openrange external dix_msg_openstruc external dix_msg_openunion external dix_msg_parerr external dix_msg_randign external dix_msg_sizerr external dix_msg_toomdim external dix_msg_typbitf external dix_msg_unkendc external dix_msg_unkline external dix_msg_ranstru external dix_msg_evalerr external dix_msg_userstd external dix_msg_ptrerr external dix_msg_illifnest external dix_msg_maxifdep external dix_msg_openif external dix_msg_ignqual c integer*4 deep_structure,deep_map,deep_union,prev_ent_typ_nor integer*4 range_deep_structure,range_deep_map,range_deep_union integer*4 fieldname_status,flags,prev_ent_typ_vfc,prev_ent_typ integer*4 var_override_vfc,var_override_nor record /repeat/ rep record /dimension/ dim integer*4 nkar_o c c start of coding c errline = ' ' dix_des_process_lines = .false. deep_structure = 0 deep_map = 0 deep_union = 0 deep_if = 0 range_deep_structure = 0 range_deep_union = 0 range_deep_map = 0 fixed = .true. field_mode = .false. err_linenr = 0 has_pointer_vfc = .false. has_pointer_nor = .false. c var_override_nor = 0 var_override_vfc = 0 c c Init the values for location c these are witout a value, but thius value will be filled c when expanding c call dix_symbol_add_int(control,'%BIT_LOCATION',0,line1) !for now 0 call dix_symbol_add_int(control,'%LOCATION',0,line1) !for now 0 c c read lines c prev_ent_typ_vfc = 0 prev_ent_typ_nor = 0 c skip = .false. 10 nkar = 0 nkar_o = 0 c 11 istat = memtab_read(p_memtab,nkar1,line1) if(.not. istat) goto 90 err_linenr = err_linenr + 1 c c skip comment and trailing blanks c if(.not. dix_util_remove_comment(nkar1,line1)) then call dix_message(control,dix_msg_openquote) errline = line1 nkar_o = 0 goto 80 endif c c See if continuation line c line(nkar+1:) = line1(1:nkar1) oline(nkar_o+1:) = line1(1:nkar1) c nkar = nkar + nkar1 nkar_o = nkar_o + nkar1 if(nkar .gt. 0) then if(line(nkar:nkar) .eq. '-') then nkar = nkar-1 nkar_o = nkar_o - 1 goto 11 end if c if(line(1:1) .eq. 'C' .or. line(1:1) .eq. 'c') goto 10 !if firts char is C, then exit c c Now remove double blanks etc, and all cahrs to upcase(out of quotes) c call dix_util_decent_line(nkar,line) endif if(nkar .eq. 0) goto 10 c c Skip the userdefined types c if(skip) then if(dix_des_is_type(line(1:nkar),.false.,username)) then skip = .false. endif goto 10 else if(dix_des_is_type(line(1:nkar),.true.,username)) then skip = .true. goto 10 endif endif c c save line in case of error c call str$upcase(line,line) if(line(1:1) .eq. '*') goto 10 c c We cannot use DCL parsing, since the syntax is too cryptic c f.e. character*(20) jan(20) etc., etc. c range_data = ' ' !no range yet no_display = .false. !Not nodisplay mode user = .false. !not user defined case = des_flag_case_no_case !dono translate to upper/lower case trans_override = des_flag_translate_nor readonly = .false. is_vfc = .false. p_link_rec = 0 nk_limit_value = 0 username = ' ' !assume not user defined type relative = .false. !assume position statement is not relative zero_fill = .false. !decimal: zero fill specified exponent = .false. !decimal: exponent allowed fraction = .false. !decinal: allow fractions leftjust = .false. !decimal: no left justify force_var = .false. !no forced variable c c Parse the if/else/elseif/endif parts c nk_nam = 0 jpos = 0 size = 0 nk_Size_asc = 0 nk_limit_value = 0 nb_reserved = 0 ipos = index(line(1:nkar),' ') if(ipos .eq. 0) ipos = nkar+1 call dix_des_init_rep(rep) c if(line(1:ipos-1) .eq. '#IF' .or. 1 line(1:ipos-1) .eq. '#IFDEF') then if(deep_if .eq. max_depth) then call dix_message(control,dix_msg_maxifdep) goto 80 endif if(line(1:ipos-1) .eq. '#IFDEF') then c c Now the rest of the line should be a value symbol name c ent_type = enttyp_ifdef if(line(ipos+1:nkar) .eq. ' ') goto 66 istat = dix_util_check_name(line(ipos+1:nkar)) if(.not. istat) then call dix_message(control,%val(istat),line(ipos+1:nkar)) goto 80 endif else ent_type = enttyp_if c c Now the rest of the line should be a logical expression c if(line(ipos+1:nkar) .eq. ' ') goto 66 istat = dix_eval_check(control,line(ipos+1:nkar),errline) if(.not. istat) goto 66 c c Insert if statement c endif limit_value = line(ipos+1:nkar) nk_limit_value = nkar-ipos deep_if = deep_if + 1 goto 56 elseif(line(1:ipos-1) .eq. '#ELSE') then if(deep_if .eq. 0) goto 67 ent_type = enttyp_else goto 56 elseif(line(1:ipos-1) .eq. '#ELSEIF') then if(deep_if .eq. 0) goto 67 ent_type = enttyp_elseif c c Insert elseif string c if(line(ipos+1:nkar) .eq. ' ') goto 66 istat = dix_eval_check(control,line(ipos+1:nkar),errline) if(.not. istat) goto 66 limit_value = line(ipos+1:nkar) nk_limit_value = nkar-ipos goto 56 elseif(line(1:ipos-1) .eq. '#ENDIF') then if(deep_if .eq. 0) goto 67 ent_type = enttyp_endif deep_if = deep_if - 1 goto 56 elseif(line(1:ipos-1) .eq. '#MESSAGE') then ent_type = enttyp_message c c Insert elseif string c if(line(ipos+1:nkar) .eq. ' ') goto 66 limit_value = line(ipos+1:nkar) nk_limit_value = nkar-ipos goto 56 endif c c See if qualifiers specified c 12 ipos = index(line(1:nkar),'/') if(ipos .ne. 0) then c c Check for override translate /HEXADECIMAL,/BINARY,/OCTAL,/RANGE=MIN:MAX/UPPERCASE/LOWERCASE c and the file link qualifiers /file=/key=/match=/compute=/REC/limit c and the user type /user/readonly/limit="limitexpression" c and the position /relative c c do not do this for a structure statement c the fortran symtax is structure /name/ c Dix expects the syntax "structure name", so remove both //'s c call str$upcase(typ,line(1:ipos-1)) if(typ .eq. 'STRUCTURE') then c c Skip the slash, and also the terminating one c line(ipos:ipos) = ' ' do k=ipos,nkar if(line(k:k) .eq. '/') then line(k:k) = ' ' goto 13 endif enddo else istat = dix_des_get_qualifier(control,line,nkar,ipos,p_link_rec, 1 vm_zone,trans_override,no_display,range_data, 1 user,case,nk_limit_value,limit_value,readonly,is_vfc, 1 relative,zero_fill,exponent,fraction,leftjust) if(istat) goto 12 errline = ' ' call dix_message(control,%val(istat)) goto 80 endif endif c c And decent the line again c 13 call dix_util_decent_line(nkar,line) c c if(is_vfc) then prev_ent_typ = prev_ent_typ_vfc p_des_rec_fils = table_vfc.address n_des_rec_fils = table_vfc.count else prev_ent_typ = prev_ent_typ_nor p_des_rec_fils = table_nor.address n_des_rec_fils = table_nor.count end if c c now we have format c type*size var(d1,d2,d3) c line(nkar+1:) = ' ' c c take first item is separated from the next by a space c ipos = index(line,' ') typ = line(1:ipos-1) line = line(ipos+1:) c nkar = nkar - ipos c c take some special cases c 1. end structure = endstructure c 2. end map = endmap c 3. end union = endunion c 4. byte = integer*1 c if(typ .eq. 'END') then if(line .eq. 'STRUCTURE') then typ = 'ENDSTRUCTURE' elseif(line .eq. 'MAP') then typ = 'ENDMAP' elseif(line .eq. 'UNION') then typ = 'ENDUNION' elseif(line .eq. 'BITFIELD') then typ = 'ENDBITFIELD' elseif(line .eq. 'RANGE') then typ = 'ENDRANGE' else c c unsupported case c call dix_message(control,dix_msg_unkendc,typ) goto 80 endif ipos = index(line,' ') line = line(ipos+1:) end if c if(typ .eq. 'PARAMETER') then c c Parameter can have 2 formats c parameter a=1 c parameter (a=1,b=1) c In the second case : get rid of the () c if(line(1:1) .eq. '(') then jpos = dix_util_find_char_bracket(line,')',.false.) if(jpos .eq. 0) then call dix_message(control,dix_msg_parerr) goto 80 endif line = line(2:jpos-1) endif c c Split line in parts, get the , as separator c 1411 jpos = dix_util_find_char_bracket(line,',',.false.) if(jpos .eq. 0) jpos = len(line)+1 c c Split element in two parts c 1. name c 2. expression c ipos = index(line(1:jpos),'=') if(ipos .eq. 0) then call dix_message(control,dix_msg_parerr) goto 80 endif istat = dix_util_check_name(line(1:ipos-1)) if(.not. istat) then call dix_message(control,%val(istat),line(1:ipos-1)) else param_rec.name = line(1:ipos-1) c c Try to evaluate the expression c ntyp = line(ipos+1:jpos-1) nk = jpos-ipos-1 param_rec.hex = des_flag_translate_nor if(index(ntyp,'''B') .ne. 0) param_rec.hex=des_flag_translate_bin if(index(ntyp,'''O') .ne. 0) param_rec.hex=des_flag_translate_oct if(index(ntyp,'''X') .ne. 0) param_rec.hex=des_flag_translate_hex call dix_util_collapse(ntyp,nk,.false.) istat = dix_eval_express_int(control,ntyp(1:nk), 1 param_rec.value,errline,.false.) if(.not. istat) then nk1 = dix_util_get_len_fu(errline) call dix_message(control,%val(istat),errline(1:nk1)) call dix_message(control,dix_msg_parerr) goto 80 endif c c Append the parameter record to the list, c call dix_util_insert_table(control, 1 parameters,param_rec,20,vm_zone,'PARAMETER') c c See if still more on the line c endif if(jpos .le. len(line)) then line = line(jpos+1:) goto 1411 endif goto 10 end if c c is_variable = .false. fieldname_status = des_flag_fieldname_status_none c if(.not. field_mode) then if(typ .eq. 'BYTE' ) typ = 'INTEGER*1' if(typ .eq. 'UBYTE' ) typ = 'UINTEGER*1' endif c c take off the *size c ipos = index(typ,'*') if(ipos .eq. 0) then size = 0 !default size else c c compute the size, forget then () in case of *(Nn) c if(typ(ipos+1:ipos+1) .eq. '(') then kk = dix_util_find_char_bracket(typ(ipos+1:),')',.false.) if (kk .eq. 0) goto 69 kk = kk + ipos size_asc = typ(ipos+2:kk-1) nk_size_asc = kk-1 - ipos-2 + 1 istat = dix_eval_check(control,size_asc(1:nk_size_asc),errline) if(.not. istat) goto 66 typ(ipos+1:ipos+1) = ' ' !clear ( typ(kk:kk) = ' ' !clear ) end if c c read the size, in error give error message c read(typ(ipos+1:),2034,err=34) size 2034 format(bn,i6) nk_size_asc = 0 !clear if valid read goto 35 34 if(nk_size_asc .eq. 0) goto 69 35 typ(ipos:) = ' ' end if if (.not. field_mode) size = size*bits_per_byte c c Set repeat low and high all on 1 (dimension statement) c got_dimension = .false. c c see if dimension specified. c but not for MAP statement c if(typ .eq. 'MAP') goto 45 ipos = index(line,'(') kk = index(line,'[') if(kk .gt. 0 .and. ipos .gt. kk) ipos = 0 !( in []part c if(ipos .ne. 0) then c c yes so read all the intermediate dimensions (upto max_dimension=3) c rep.has_dims = .true. got_dimension = .true. kk = 1 !dimension index 1..3 ntyp = line(ipos:) !the dimension in ntyp jpos = dix_util_find_char_bracket(ntyp,')',.false.) if(jpos .eq. 0) goto 69 ntyp(jpos:) = ' ' !remove trailing bracket ntyp(1:1) = ' ' !remove leading ( line(ipos:) = line(ipos+jpos:) !clear out dimension part call dix_util_collapse(ntyp,jpos,.false.) c c Now ntyp contains the dimension without the surrounding brackets c do while(ntyp .ne. ' ') ipos = dix_util_find_char_bracket(ntyp,',',.false.) c if(ipos .eq. 0) ipos = dix_util_find_char_bracket(ntyp,' ', 1 .false.) c c Now we have the first dim c if(ipos .eq. 0) goto 69 c c read the size, if error, then exit c dimension can be nn or ll:hh c dim.low_is_star = .false. call dix_util_clear_descr(dim.low_name,.false.) call dix_util_clear_descr(dim.high_name,.false.) dim.low = 1 !set defaults dim.high = 1 jpos = dix_util_find_char_bracket(ntyp(1:ipos),':',.false.) if(jpos .ne. 0) then c c We have the low part in ntyp(1:jpos-1) c if(.not. dix_des_conv_idx(ntyp(1:jpos-1),dim.low)) then istat = dix_eval_check(control,ntyp(1:jpos-1),errline) if(.not. istat) goto 66 if(ntyp(1:jpos-1) .eq. '*') dim.low_is_star = .true. call dix_util_insert_string(control,dim.low_name, 1 vm_zone,ntyp(1:jpos-1)) force_var = .true. !depending?? endif c c Skipt the low part c ntyp = ntyp(jpos+1:) ipos = ipos - jpos end if c c Now the high c if(ntyp(1:ipos-1) .eq. '*') then dim.high = '7fffffff'x !take max value else if(.not. dix_des_conv_idx(ntyp(1:ipos-1),dim.high)) then istat = dix_eval_check(control,ntyp(1:ipos-1),errline) if(.not. istat) goto 66 call dix_util_insert_string(control,dim.high_name, 1 vm_zone,ntyp(1:ipos-1)) force_var = .true. !depending?? endif endif c c we have a new dimension; may have no more than 3 c if(kk .gt. max_dimension) then call dix_message(control,dix_msg_toomdim) goto 80 end if rep.dim(kk) = dim kk = kk + 1 c c skip this dimension, and up for the next c ntyp = ntyp(ipos+1:) end do end if nkar = len(line) call dix_util_collapse(line,nkar,.false.) c c take the cases, check for the sizes c c 45 nb_reserved = 0 default_size = 32 if(field_mode) default_size = 8 c if(range_data .ne. ' ') then nbr = size if(nbr .eq. 0) nbr = default_size errline = 'error in range' if(.not. dix_des_get_range(control,range_data, 1 min_val,max_val,nbr)) then call dix_message(control,dix_msg_invrange) goto 80 endif force_var = .true. ! else min_val = 0 max_val = 0 endif c c if(typ .eq. 'INTEGER') then c c (signed) integer must be >1 and <=64 bits c ent_type = enttyp_int range_data = ' ' fieldname_status = des_flag_fieldname_status_singl elseif(typ .eq. 'UINTEGER') then ent_type = enttyp_uint range_data = ' ' fieldname_status = des_flag_fieldname_status_singl elseif(typ .eq. 'BITS') then ent_type = enttyp_bits fieldname_status = des_flag_fieldname_status_multi elseif(typ .eq. 'RBITS') then ent_type = enttyp_rbits fieldname_status = des_flag_fieldname_status_mulrv elseif(typ .eq. 'LOGICAL') then ent_type = enttyp_log elseif(typ .eq. 'RLOGICAL') then ent_type = enttyp_rlog elseif(typ .eq. 'DATE') then ent_type = enttyp_dat fieldname_status = des_flag_fieldname_status_singl elseif(typ .eq. 'DELTATIME') then ent_type = enttyp_deltatime fieldname_status = des_flag_fieldname_status_singl elseif(typ .eq. 'CPUTIME') then ent_type = enttyp_cpu elseif(typ .eq. 'UIC') then ent_type = enttyp_uic elseif(typ .eq. 'IDENTIFIER') then ent_type = enttyp_identifier elseif(typ .eq. 'VFC') then ent_type = enttyp_vfc elseif(typ .eq. 'ABORT') then ent_type = enttyp_abort elseif(typ .eq. 'PROTECTION') then ent_type = enttyp_prot elseif(typ .eq. 'FILEID') then ent_type = enttyp_fid elseif(typ .eq. 'RINTEGER') then ent_type = enttyp_revint elseif(typ .eq. 'REAL_F') then ent_type = enttyp_real_f elseif(typ .eq. 'REAL_G') then ent_type = enttyp_real_g elseif(typ .eq. 'REAL_H') then ent_type = enttyp_real_h elseif(typ .eq. 'REAL_X') then ent_type = enttyp_real_x elseif(typ .eq. 'REAL_S') then ent_type = enttyp_real_s elseif(typ .eq. 'REAL_T') then ent_type = enttyp_real_t elseif(typ .eq. 'REAL_D') then ent_type = enttyp_real_d elseif(typ .eq. 'REAL') then c c Undefined case, take the platform default c _f,_d,_h for vax c _f,_g,_x for alpha c _t,_s,_x for Itanium c if(field_mode) goto 68 if(size .eq. 0) size =4 call dix_con_cvt_float_type(control,size,ent_type) size = size*bits_per_byte elseif(typ .eq. 'POSITION') then c c The position is absolute unless c /relative is given, c the value is negative c ent_type = enttyp_position size = 0 is_variable = .true. if(rep.dim(1).high .lt. 0) relative = .true. elseif(typ .eq. 'ACL') then is_variable = .true. ent_type = enttyp_acl elseif(typ .eq. 'RANGE') then if(field_mode) goto 68 if(.not. got_dimension) then call dix_message(control,dix_msg_norangs) goto 80 endif if(in_range) then call dix_message(control,dix_msg_nestrange) goto 80 end if range_deep_structure = deep_structure range_deep_union = deep_union range_deep_map = deep_map in_range = .true. ent_type = enttyp_range size = 0 force_var = .true. elseif(typ .eq. 'ENDRANGE') then if(field_mode) goto 68 if(.not. in_range) then call dix_message(control,dix_msg_norange) goto 80 end if if(deep_structure .ne. range_deep_structure .or. 1 deep_union .ne. range_deep_union .or. 1 deep_map .ne. range_deep_map) then goto 65 endif c in_range = .false. ent_type = enttyp_endrange size = 0 elseif(typ .eq. 'DISKMAP') then ent_type = enttyp_diskmap is_variable = .true. elseif(typ .eq. 'CHARACTER') then ent_type = enttyp_chr elseif(typ .eq. 'DECIMAL') then ent_type = enttyp_decimal elseif(typ .eq. 'UDECIMAL') then ent_type = enttyp_udecimal elseif(typ .eq. 'STRING') then ent_type = enttyp_string elseif(typ .eq. 'WSTRING') then ent_type = enttyp_wstring elseif(typ .eq. 'LSTRING') then ent_type = enttyp_lstring elseif(typ .eq. 'HSTRING') then !terminated by 8bitchar ent_type = enttyp_hstring elseif(typ .eq. 'ZSTRING') then !terminated by 0 ent_type = enttyp_zstring elseif(typ .eq. 'PAD' .or. typ .eq. 'ALIGN') then is_variable = .true. if(size .eq. 0) then if(field_mode) then size = bits_per_byte else size = 2*bits_per_byte endif endif if(size .lt. 1 .or. size .gt. 8*bits_per_byte) goto 70 des_rec_fils(n_des_rec_fils).pad_value = size goto 10 !skip this one c elseif(typ .eq. 'STRUCTURE') then if(field_mode) goto 68 if(deep_structure .eq. max_depth) then call dix_message(control,dix_msg_maxstrdep) goto 80 end if c c One more structure, remember lin number in input file c deep_structure = deep_structure + 1 if(deep_structure .eq. 1) then if(is_vfc) then var_override_vfc = table_vfc.count+1 else var_override_nor = table_nor.count+1 endif endif c c Remember current prefix length (for truncating on endstructure) c ent_type = enttyp_structure elseif(typ .eq. 'ENDSTRUCTURE') then c c endstructure, if repeat count exceeded than all ok c if not exceeded skip back file to correct line c if(deep_structure .eq. range_deep_structure) goto 65 if(field_mode) goto 68 if(deep_structure .eq. 0) then call dix_message(control,dix_msg_nostruct) goto 80 end if deep_structure = deep_structure-1 if(deep_structure .eq. 0) then if(is_vfc) then var_override_vfc = 0 else var_override_nor = 0 endif endif ent_type = enttyp_endstructure c c could not find structure, so error c elseif (typ .eq. 'MAP') then if(field_mode) goto 68 if(deep_map .ne. deep_union-1) then call dix_message(control,dix_msg_nounion) goto 80 end if c c The previous must be a union or an end_map c if(prev_ent_typ .ne. enttyp_union .and. 1 prev_ent_typ .ne. enttyp_endmap) then call dix_message(control,dix_msg_mapfoll) goto 80 endif deep_map = deep_map + 1 ent_type = enttyp_map nk = len(line) call dix_util_collapse(line,nk,.false.) c if(line .ne. ' ') then c c Syntax = 1 MAP fieldname = intvalue (can have any value) c Separate fieldname from value c ipos = index(line,'=') if(ipos .eq. 0) then if(line .eq. '*') then ipos = 2 else call dix_message(control,dix_msg_errdepen) goto 80 endif else istat = dix_eval_check(control,line(1:ipos-1),errline) if(.not. istat) goto 66 endif if(line(1:ipos-1) .eq. '*') rep.dim(1).low_is_star = .true. call dix_util_insert_string(control,rep.dim(1).low_name, 1 vm_zone,line(1:ipos-1)) call dix_util_insert_string(control,rep.dim(1).high_name, 1 vm_zone,line(ipos+1:nk)) line = ' ' end if elseif (typ .eq. 'ENDMAP') then if(deep_map .eq. range_deep_map) goto 65 if(field_mode) goto 68 c c look for previous map c if(deep_map .ne. deep_union) then call dix_message(control,dix_msg_nomap) goto 80 end if deep_map = deep_map-1 ent_type = enttyp_endmap elseif (typ .eq. 'POINTER') then if(field_mode) goto 68 if(size .eq. 0) size = 4*bits_per_byte if(size .le. 0 .or. size .gt. 4*bits_per_byte) goto 70 ent_type = enttyp_pointer if(is_vfc) then has_pointer_vfc = .true. else has_pointer_nor = .true. endif elseif (typ .eq. 'EXIT') then c c EXIT can only happen in structure c if(field_mode) goto 68 if(deep_structure .eq. 0) then call dix_message(control,dix_msg_nostruct) goto 80 end if ent_type = enttyp_exit elseif (typ .eq. 'UNION') then if(field_mode) goto 68 if(deep_union .eq. max_depth_union) then call dix_message(control,dix_msg_maxunidep) goto 80 end if deep_union = deep_union + 1 ent_type = enttyp_union elseif (typ .eq. 'ENDUNION') then if(deep_union .eq. range_deep_union) goto 65 if(field_mode) goto 68 c c look for previous union c if(deep_union .eq. 0) then call dix_message(control,dix_msg_nounion) goto 80 end if c c Teh previous must be union/endmap c if(prev_ent_typ .ne. enttyp_union .and. 1 prev_ent_typ .ne. enttyp_endmap) then call dix_message(control,dix_msg_endufoll) goto 80 endif deep_union = deep_union - 1 ent_type = enttyp_endunion elseif(typ .eq. 'BITFIELD') then has_fields = .true. if(field_mode) then call dix_message(control,dix_msg_nestbitf) goto 80 endif ent_type = enttyp_field field_mode = .true. elseif(typ .eq. 'ENDBITFIELD') then if(.not. field_mode) then call dix_message(control,dix_msg_nobitf) goto 80 endif ent_type = enttyp_endfield field_mode = .false. is_variable = .true. else c c unsupported case c check it usermode wanted c if(user) then nkar1 = dix_util_get_len_fu(typ) istat = dix_inter_read_command_usertype(lun_user,control, 1 typ(1:nkar1),p_usertypes) if(istat) then if(size .lt. 0 .or. size .gt. 65535*bits_per_byte) goto 70 if(size .eq. 0) is_variable = .true. ent_type = enttyp_user username = typ is_variable = .true. goto 51 else goto 80 endif endif call dix_message(control,dix_msg_unkline) goto 80 end if c c Some qualifiers are not always valid c if(zero_fill .or. exponent .or. fraction .or.leftjust) then if(ent_type .ne. enttyp_decimal .and. 1 ent_type .ne. enttyp_udecimal) then c c Wronmg combination c call dix_message(control,dix_msg_ignqual, 1 '/ZERO_FILL,/FRACTION,/LEFTJUST or /EXPONENT', 1 '[U]DECIMAL') zero_fill = .false. exponent = .false. fraction = .false. leftjust = .false. endif endif c c Now check for the validity of size/typ in this field_mode c istat = dix_con_check_field_size(ent_type,size,nb_reserved, 1 field_mode,field_ok, 1 is_variable,known) if(.not. field_ok) goto 68 !invalid in field mode if(.not. istat) goto 70 !not valid size c if(size .ne. 0) size = size + nb_reserved*bits_per_byte lun_user = 0 if(user) then c c If we came here and user is set, c user tried to redefine standard type c nkar1 = dix_util_get_len_fu(typ) call dix_message(control,dix_msg_userstd,typ(1:nkar1)) goto 80 endif c c store the results c save name () is now deleted C 51 nk = dix_util_get_len(line) !and length jpos = index(line,'[') !see if fields specified c c See if the name is not double defined c nk_nam = nk if(jpos .gt. 0) nk_nam = jpos-1 c c Check if name is not double defined, c do not check for items not displayed c is_filler = line(1:1) .eq. '%' c if(.not. is_filler .and. .not. no_display .and. 1 line(1:nk_nam) .ne. ' ') then c c The p_des_rec_fils is set to (near label 13) c either the des_rec_fils_vfc (in vfc mode) c or to des_rec_fils (normal mode) c do k=n_des_rec_fils,1,-1 if(des_rec_fils(k).ent_type .eq. enttyp_structure) goto 55 if(des_rec_fils(k).name .eq. line(1:nk_nam)) then call dix_message(control,dix_msg_doubldef,line(1:nk_nam)) goto 80 end if end do endif c c Check for a valid syntax (not for % fields) c 55 if(.not. is_filler) then istat = dix_util_check_name(line(1:nk_nam)) if(.not. istat) then call dix_message(control,%val(istat),line(1:nk_nam)) goto 80 endif endif c c One more item c 56 des_rec_fil.nam_len = nk_nam des_rec_fil.name = line(1:nk_nam) c c Check on fieldnames separator c call dix_util_clear_descr(des_rec_fil.fldnam,.false.) if(jpos .ne. 0) then c c there was a [, so look for ] (if not found take eol) c jpos = index(line,'[') ipos = index(line,']') !compute new length if(ipos .eq. 0) goto 80 c c Allocate some room, and copy descrip c line = line(jpos+1:ipos-1) nk = ipos-jpos-1 if(line .ne. ' ') then if(ent_type .eq. enttyp_abort) then c c For the abort command the part between the [] is a conditional c istat = dix_eval_check(control,line(1:nk),errline) if(.not. istat) goto 66 else c c we search again in oline, since that has the case unchanged c jpos = index(oline,'[') ipos = index(oline,']') line = oline(jpos+1:ipos-1) nk = ipos-jpos-1 c c remove all blanks c call dix_util_compress_line(line,nk,.true.) endif c c And insert it c call dix_util_insert_string(control,des_rec_fil.fldnam, 1 vm_zone,line(1:nk)) end if else if(ent_type .eq. enttyp_pointer) then call dix_message(control,dix_msg_ptrerr,des_rec_fil.name) goto 92 endif end if des_rec_fil.ent_type = ent_type des_rec_fil.size = size c call dix_util_insert_string(control,des_rec_fil.size_asc, 1 vm_zone,size_asc(1:nk_size_asc)) call dix_util_insert_string(control,des_rec_fil.limit_value, 1 vm_zone,limit_value(1:nk_limit_value)) c c Fill flag field, low byte is nb_reserved c flags = nb_reserved !is low nibble c c Nibble 3 c if(field_mode) flags = flags .or. des_flag_is_field if(is_variable) flags = flags .or. des_flag_is_variable flags = flags .or. case c c Nibble 4 c flags = flags .or. trans_override flags = flags .or. fieldname_status c c Nibble 5 c if(is_filler) flags = flags .or. des_flag_is_filler if(no_display) flags = flags .or. des_flag_no_display if(rep.has_dims) flags = flags .or. des_flag_has_repeat if(nk_size_asc .gt.0)flags = flags .or. des_flag_has_size_asc c c Nibble 6 c if(field_mode) flags = flags .or. des_flag_field_mode if(readonly) flags = flags .or. des_flag_readonly c c Nibble 7, vfc vlag, litmit value and relative flag for position c if(nk_limit_value .gt. 0) flags = flags .or. des_flag_has_limit if(is_vfc) flags = flags .or. des_flag_is_vfc if(relative ) flags = flags .or. des_flag_is_relative c c Nibble 8, decimal flags c if(zero_fill) flags = flags .or. des_flag_decimal_zerofill if(exponent ) flags = flags .or. des_flag_decimal_exponent if(fraction ) flags = flags .or. des_flag_decimal_fraction if(leftjust ) flags = flags .or. des_flag_decimal_leftjust c des_rec_fil.flags = flags des_rec_fil.min_val = min_val des_rec_fil.max_val = max_val des_rec_fil.p_link_rec = p_link_rec des_rec_fil.lun_translate= lun_user des_rec_fil.username = username des_rec_fil.pad_value = 0 des_rec_fil.magic = magic_des_rec_fil c if(is_variable) fixed = .false. des_rec_fil.rep = rep if(range_data .ne. ' ') then call dix_message(control,dix_msg_randign) endif c c Now store in the correct table c if(is_vfc) then c c Insert tot vfc list c call dix_util_insert_table(control, 1 table_vfc,des_rec_fil,5,vm_zone,'VFC_DES_REC') if(is_variable .or. force_var) then c c Either variable field, or depending field c this element is the first that must be reevaluated c if(first_vfc_var .eq. 0) then if(var_override_vfc .ne. 0) then first_vfc_var = var_override_vfc else first_vfc_var = table_vfc.count endif endif endif prev_ent_typ_vfc = des_rec_fil.ent_type else c c Insert tot normal list c call dix_util_insert_table(control, 1 table_nor,des_rec_fil,50,vm_zone,'DES_REC') if(is_variable .or. force_var) then c c Either variable field, or depending field c this element is the first that must be reevaluated c if(first_nor_var .eq. 0) then if(var_override_nor .ne. 0) then first_nor_var = var_override_nor else first_nor_var = table_nor.count endif endif endif prev_ent_typ_nor = des_rec_fil.ent_type endif goto 10 65 call dix_message(control,dix_msg_ranstru) goto 80 66 nk1 = dix_util_get_len_fu(errline) call dix_message(control,%val(istat),errline(1:nk1)) call dix_message(control,dix_msg_evalerr) goto 80 67 call dix_message(control,dix_msg_illifnest) goto 80 68 call dix_message(control,dix_msg_typbitf,typ) goto 80 c c Error in dimension c 69 call dix_message(control,dix_msg_dimerr) goto 80 c c Error in repeat count c 70 call dix_message(control,dix_msg_sizerr,%val(size)) goto 80 c c format error in line c 80 nke = dix_util_get_len_fu(errline) if(nke .gt. 0) call dix_message(control,dix_msg_general, 1 errline(1:nke)) if(nkar_o .gt. 0) then call dix_message(control,dix_msg_errinline,oline(1:nkar_o)) endif goto 92 c c Could not open record file c c Normal exit; check for open structures c 90 dix_des_process_lines = .true. if(first_vfc_var .eq. 0) first_vfc_var = table_vfc.count + 1 if(first_nor_var .eq. 0) first_nor_var = table_nor.count + 1 if(deep_structure .ne. 0) then call dix_message(control,dix_msg_openstruc) goto 92 end if if(deep_union .ne. 0) then call dix_message(control,dix_msg_openunion) goto 92 end if if(deep_if .ne. 0) then call dix_message(control,dix_msg_openif) goto 92 end if if(deep_map .ne. 0) then call dix_message(control,dix_msg_openmap) goto 92 end if if(field_mode) then call dix_message(control,dix_msg_openbitf) goto 92 end if if(in_range) then call dix_message(control,dix_msg_openrange) goto 92 end if c if(has_pointer_vfc) then if(.not. dix_des_correct_pointer(table_vfc.count, 1 %val(table_vfc.address))) goto 92 end if if(has_pointer_nor) then if(.not. dix_des_correct_pointer(table_nor.count, 1 %val(table_nor.address))) goto 92 end if c c All well c goto 95 c c exit in case of error, nent=0 c 92 table_nor.count = 0 !set counters to 0 table_vfc.count = 0 dix_des_process_lines = .false. c c normal exit c 95 return end function dix_des_correct_pointer(n_lin,des_rec_fils) include 'dix_def.inc' integer*4 n_lin record /des_rec_fil/ des_rec_fils(*) logical*4 dix_des_correct_pointer c integer*4 k,nk,l character*(max_command_length) line c external dix_msg_ptrnots external dix_msg_ptrnotf c dix_des_correct_pointer = .false. do k=1,n_lin if(des_rec_fils(k).ent_type .eq. enttyp_pointer) then nk = des_rec_fils(k).fldnam.dsc$w_maxstrlen call str$upcase(line(1:nk),des_rec_fils(k).fldnam) do l=1,n_lin if(line(1:nk) .eq. des_rec_fils(l).name) then if(l .lt. n_lin .and. 1 des_rec_fils(l).ent_type .ne. enttyp_structure) then call dix_message(control,dix_msg_ptrnots, 1 des_rec_fils(k).name(1:des_rec_fils(k).nam_len)) goto 90 endif c des_rec_fils(k).link_pointer = %loc(des_rec_fils(l+1)) goto 10 endif enddo c c Could not find pointer field c call dix_message(control,dix_msg_ptrnotf, 1 des_rec_fils(k).name(1:des_rec_fils(k).nam_len), 1 line(1:nk)) goto 90 end if 10 end do c c All is well c dix_des_correct_pointer = .true. 90 return end subroutine dix_des_init_rep(rep) implicit none c c Init a repeat structure to nodims c include 'dix_def.inc' record /repeat/ rep c# integer*4 kk c do kk=1,max_dimension rep.dim(kk).low = 1 rep.dim(kk).high = 1 rep.dim(kk).low_is_star = .false. call dix_util_clear_descr(rep.dim(kk).low_name,.false.) call dix_util_clear_descr(rep.dim(kk).high_name,.false.) end do rep.magic = magic_repeat rep.has_dims = .false. return end function dix_des_conv_idx(ntyp,value) implicit none c c convert a text to a number c include 'dix_def.inc' character*(*) ntyp !:i: the text integer*4 value !:o: the number logical*4 dix_des_conv_idx !:f: function result c# c dix_des_conv_idx = .false. read(ntyp,'(bn,i10)',err=90) value dix_des_conv_idx = .true. 90 return end c function dix_des_expand(control,des_expanded,file,quiet) implicit none include 'dix_def.inc' c c (re-)expand a description c record /control/ control !:i: control structure record /des_expanded/ des_expanded !:io: expanded des record /file_info/ file !:i: the file data logical*4 quiet !:i: do no signal errors logical*4 dix_des_expand !:f: function result c# character*(max_filename_length) line c integer*4 max_data,vfc_max_data,nk,ndes_vfc integer*4 save_file,save_des c logical*4 dix_des_expand_1 external dix_msg_dessmall c record /des_info/ des_info pointer (p_des_info,des_info) c c if(des_expanded.is_expanded) then dix_des_expand = .not. des_expanded.expand_error call dix_main_print_debug(control,debug_expand, 1 'desc '//des_expanded.handle// 1 ' is already expanded') goto 90 endif call dix_main_print_debug(control,debug_expand, 1 'expanding desc '//des_expanded.handle) c c des_expanded.expand_error = .false. c c c We have to set this flag here, otherwise we get an endless recursion c des_des_expand_1 calls dix_eval_expression. c dix_eval_expression calls dix_des_find_field c dix_des_find_field checks if the des_Expanded (this one) is expanded c if not call _expand and the circle is closed c des_expanded.is_expanded = .true. c p_des_info = des_expanded.p_des_info c c c Make sure this file/descriptor is the current c sinc field references can call to dix_eval_expression, c and if then fieldnames are referenced, they are done against the c current file/desc c save_file = control.cur_file control.cur_file = %loc(file) c save_des = file.cur_des file.cur_des = %loc(des_expanded) c c It the file has vfc data, expand these descriptions now c (at least if there is a current record) c if(file.data.nb_vfc .gt. 0) then ndes_vfc = des_info.table_vfc.count if(ndes_vfc .eq. 0) then c c If the user did not specify vfc types, and the byte count is exactly 2 c (the normal dcl vfc files, help the user by adding to records to c the descriptions with two enttyp_vfc c if(file.data.nb_vfc .eq. 2) then c c 2 byte vfc type c call dix_des_add_vfc_entry(ndes_vfc,'PRE', 1 %val(des_info.table_vfc.address),0) call dix_des_add_vfc_entry(ndes_vfc,'POST', 1 %val(des_info.table_vfc.address),0) else c c Table if byte(n_vfc) c call dix_des_add_vfc_entry(ndes_vfc,'VFC_DATA', 1 %val(des_info.table_vfc.address), 1 file.data.nb_vfc) endif endif dix_des_expand = dix_des_expand_1(control, 1 ndes_vfc,%val(des_info.table_vfc.address), 1 file.data.nb_vfc,file.data.vfc_data, 1 des_info.first_vfc_var, 1 des_expanded.table_vfc, 1 des_expanded.vfc_nfield_notcompressed, 1 des_expanded.vfc_max_name_size,vfc_max_data, 1 des_expanded.zone_rec,quiet, 1 des_expanded.fieldnames_vfc) else dix_des_expand = .true. des_expanded.table_vfc.count = 0 endif if(dix_des_expand) then dix_des_expand = dix_des_expand_1(control, 1 des_info.table_nor.count, 1 %val(des_info.table_nor.address), 1 des_info.first_nor_var, 1 file.data.nb_data,file.data.data_rec, 1 des_expanded.table_nor, 1 des_expanded.nfield_notcompressed, 1 des_expanded.max_name_size,max_data, 1 des_expanded.zone_rec,quiet, 1 des_expanded.fieldnames_nor) endif if(dix_des_expand) then des_expanded.expand_error = .false. else des_expanded.expand_error = .true. des_expanded.table_nor.count = 0 des_expanded.table_vfc.count = 0 endif c c if((control.debug .and. debug_expand) .ne. 0) then call dix_main_print_debug(control,debug_expand, 1 'Setting expand flag for '// 1 des_expanded.handle(1:des_expanded.nk_handle)) endif c c Now restore the original current file/descr c file.cur_des = save_des control.cur_file = save_file c c Signal short descriptions (if wanted) c if(file.data.nb_data .gt. max_data .or. 1 file.data.nb_vfc .gt. vfc_max_data) then if(.not. quiet) then call dix_des_display(control,des_info,line,nk,.true.) call dix_message(control,dix_msg_dessmall,line(1:nk)) endif end if call dix_symbol_delete(control,'%BIT_LOCATION',.false.,.true.,.true.) call dix_symbol_delete(control,'%LOCATION',.false.,.true.,.true.) 90 return end subroutine dix_des_add_vfc_entry(ndes,name,des_rec_fil,nb) implicit none c c Include an entry for a byte in the vfc area c if nb = 0 , this is a vfc type of 1 byte c if nb <>0 , this is a bytearray for nb bytes c include 'dix_def.inc' c integer*4 ndes character*(*) name record /des_rec_fil/ des_rec_fil(*) integer*4 nb c# ndes = ndes + 1 c if(nb .eq. 0) then des_rec_fil(ndes).ent_type = enttyp_vfc else des_rec_fil(ndes).ent_type = enttyp_int endif des_rec_fil(ndes).size = 1*bits_per_byte call dix_des_init_rep(des_rec_fil(ndes).rep) if(nb .gt. 0) then des_rec_fil(ndes).rep.dim(1).low = 1 des_rec_fil(ndes).rep.dim(1).high = nb des_rec_fil(ndes).rep.has_dims = .true. endif des_rec_fil(ndes).name = name !name of field des_rec_fil(ndes).nam_len = len(name) !length name des_rec_fil(ndes).flags = des_flag_is_vfc c call dix_util_clear_descr(des_rec_fil(ndes).size_asc,.false.) call dix_util_clear_descr(des_rec_fil(ndes).fldnam,.false.) call dix_util_clear_descr(des_rec_fil(ndes).limit_value,.false.) c des_rec_fil(ndes).min_val = 0 des_rec_fil(ndes).max_val = 0 des_rec_fil(ndes).p_link_rec = 0 des_rec_fil(ndes).lun_translate = 0 des_rec_fil(ndes).username = ' ' return end function dix_des_expand_1(control,n_des,des_rec_fils, 1 first_var,nb_data,data,table,n_desnc, 1 max_size,max_data,vm_zone,quiet,fieldnames) implicit none c c DO the real expand from a description c include 'dix_def.inc' record /control/ control !:i: control structure integer*4 n_des !:i: #descriptions record /des_rec_fil/ des_rec_fils(*) !:o: the descriptions integer*4 first_var !:i: the first variable field integer*4 nb_data !:i: the size of the databuffer byte data(*) !:i: the data record /table/ table !:io: the table of things integer*4 n_desnc !:O: #fields not compressed integer*4 max_size !:o: ths max size of the name integer*4 max_data !:o: max byteoffset seen record /vm_zone/ vm_zone !:i: the vm_zone to allocate mem from logical quiet !:i: do not signal error record /table/ fieldnames !:io: table for fieldnames logical*4 dix_des_expand_1 !:f: function result c# c local vars c logical*4 dix_con_is_filler cc record /des_rec/ des_rec record /des_rec/ des_rec_w c record /des_rec/ des_recs(*) pointer (p_des_recs,des_recs) c record /des_rec_fil/ des_rec_fil pointer (p_des_rec_fil,des_rec_fil) c integer*4 size,nk,kk,bit_offset,nb_asc,k integer*4 resval logical*4 is_zero c structure /save_struct/ integer*4 nk_p integer*4 nk_r integer*4 file_line record /repeat/ rep integer*4 old_offset logical*4 empty_name end structure c structure /save_union/ integer*4 beg_offset !bit_offset for begin of union integer*4 end_offset !bit_offset for end_union integer*4 idx_last_map !i_Des for last map statement in union integer*4 idx_match_all !i_des for map statement with dependency=* integer*4 idx_end_union !i_des for end_union logical*2 used !flag is any of the map's in the union is used logical*2 override !override checks end structure c structure /save_if/ logical*4 got_code logical*4 do_code end structure c record /save_struct/ save_struct(max_depth) record /save_union / save_union(max_depth) record /save_if / save_if (0:max_depth) c integer*4 deep_structure,deep_map,save_deep_map,deep_union c logical*4 is_filler character*(max_err_arg_length) errline character*(max_line_length) prefix_line,nam,wnam integer*4 nkar_prefix,i_des,ent_type,low_lim,hig_lim,id_wnam,ipos integer nke,max_pos,range_save_bit_offset,istat,line_nr,level,l,nkar1 integer*4 pointer_bit_offset,flags,new_bit_offset,if_level,ioff integer*4 nb,ptr,pad_value logical*4 var_field,in_range,is_symbol,res c record /value/ eval_val record /strdef/ fldnam c integer*4 str$element c logical*4 dix_util_get_len_fu logical*4 dix_des_set_next integer*4 dix_eval_express_int integer*4 dix_eval_express_log logical*4 dix_eval_expression integer*4 dix_util_get_len integer*4 dix_des_check_range logical*4 dix_util_overlap logical*4 dix_symbol_find c external dix_msg_mapnfnd external dix_msg_general external dix_msg_mapnotint external dix_msg_notlog external dix_msg_desabort external dix_msg_message c c start of coding c first_var contains the index of the first element that must c be reevaluated (if 0, there is no variable field in the c description c call dix_eval_init_value(eval_val) dix_des_expand_1 = .false. errline = ' ' nb_asc = 0 deep_structure = 0 deep_map = 0 deep_union = 0 max_size = 0 max_data = 0 in_range = .false. line_nr = 0 n_desnc = 0 if_level = 0 save_if(if_level).do_code = .true. c c read lines c nkar_prefix = 0 pointer_bit_offset = 0 new_bit_offset = -1 c p_des_recs = table.address nke = 0 i_des = 0 bit_offset = 0 fieldnames.size = 0 c### C Need to process the repeat/union structures c At this moment the fast re-expand cannot be used C#### table.count = 0 c c See if we can speed up expand c if(table.count .gt. 0) then do k=1,table.count i_des = des_recs(k).link_back - %loc(des_rec_fils) i_des = i_des/sizeof(des_rec_fils(1)) + 1 bit_offset = des_recs(k).bit_offset size = des_recs(k).size if(i_des .ge. first_var) goto 5 if((bit_offset + size)/bits_per_byte .ge. nb_data) goto 5 nke = nke + des_recs(k).nam.dsc$w_maxstrlen nkar1 = des_recs(k).nam.dsc$w_maxstrlen if(des_rec.p_link_rec .ne. 0) nkar1 = nkar1 + 1 max_size = max(max_size,nkar1) end do k = table.count + 1 !first var > table bit_offset = bit_offset + size !update bit_offset i_des = i_des + 1 !point to the next des_fil_rec c c We processed al elements, if now bit_offset <>nb_data c if(bit_offset/bits_per_byte .ne. nb_data) goto 5 c 5 i_des = i_des - 1 table.count = k-1 endif c c Cannot use DO loop, i_des will change (structures) c 10 i_des = i_des + 1 11 var_field = .false. call dix_symbol_add_int(control,'%BIT_LOCATION',bit_offset,errline) call dix_symbol_add_int(control,'%LOCATION', 1 bit_offset/bits_per_byte,errline) c c See if we have processed all des entries c if(i_des .gt. n_des) goto 90 c c See if this is an if/else/elseif/endif statemenet c if(des_rec_fils(i_des).ent_type .eq. enttyp_if .or. 1 des_rec_fils(i_des).ent_type .eq. enttyp_ifdef) then if_level = if_level + 1 save_if(if_level).got_code = .false. save_if(if_level).do_code = .false. c if(save_if(if_level-1).do_code) then if(des_rec_fils(i_des).ent_type .eq. enttyp_ifdef) then c c See if symbol defined. c resval = dix_symbol_find(control, 1 des_rec_fils(i_des).limit_value,eval_val) istat = 1 else istat = dix_eval_express_log(control, 1 des_rec_fils(i_des).limit_value, 1 resval,errline,.true.) endif if(.not. istat) then if(.not. quiet) then nke = dix_util_get_len_fu(errline) call dix_message(control,%val(istat),errline(1:nke)) endif goto 99 endif if(resval) then save_if(if_level).got_code = .true. save_if(if_level).do_code = .true. endif endif goto 10 elseif(des_rec_fils(i_des).ent_type .eq. enttyp_else) then c c Else part, if we were executing code, stop it c if(save_if(if_level-1).do_code) then c c We were executing code, we can now stop it c save_if(if_level).do_code = .not. save_if(if_level).got_code if(save_if(if_level).do_code)save_if(if_level).got_code=.true. endif goto 10 elseif(des_rec_fils(i_des).ent_type .eq. enttyp_elseif) then c c Elseif, c if(save_if(if_level-1).do_code) then c save_if(if_level).do_code = .false. if(.not. save_if(if_level).got_code) then c c istat = dix_eval_express_log(control, 1 des_rec_fils(i_des).limit_value, 1 resval,errline,.true.) if(.not. istat) then if(.not. quiet) then nke = dix_util_get_len_fu(errline) call dix_message(control,%val(istat),errline(1:nke)) endif goto 99 endif c if(resval) then save_if(if_level).got_code = .true. save_if(if_level).do_code = .true. endif endif endif goto 10 elseif(des_rec_fils(i_des).ent_type .eq. enttyp_endif) then if_level = if_level - 1 goto 10 endif c c If we should not execute code, skip this one c if(.not. save_if(if_level).do_code) goto 10 c c If type = message, just display it c if(des_rec_fils(i_des).ent_type .eq. enttyp_message) then c c If we are in a construct, we could come here more often c make sure the message is displayed only once, by setting size to 1 c this is corrected at the end of this procedure c if(des_rec_fils(i_des).size .eq. 0) then call dix_message(control,dix_msg_message, 1 des_rec_fils(i_des).limit_value) des_rec_fils(i_des).size = 1 endif goto 10 endif c c no, so process the next one c C Check on var data c Handle var dimension (only for character*(field) c if((des_rec_fils(i_des).flags .and. des_flag_has_size_asc) 1 .ne. 0) then istat = dix_eval_express_int(control, 1 des_rec_fils(i_des).size_asc, 1 resval,errline,.true.) if(istat) then des_rec_fils(i_des).size = resval*bits_per_byte else if(.not. quiet) then nke = dix_util_get_len_fu(errline) call dix_message(control,%val(istat),errline(1:nke)) endif goto 99 endif endif c c Handle exit, if user specified field go execute the statement c if(des_rec_fils(i_des).ent_type .eq. enttyp_exit) then c if(des_rec_fils(i_des).fldnam.dsc$w_maxstrlen .ne. 0) then c istat= dix_eval_expression(control,des_rec_fils(i_des).fldnam, 1 eval_val,.false.,errline,.true.,is_symbol) if(eval_val.type .ne. symb_typ_log) then call dix_message(control,dix_msg_notlog, 1 des_rec_fils(i_des).fldnam) res = .false. else res = eval_val.lval endif else c c No statement, exit structure anyhow c res = .true. endif if(res) goto 80 goto 10 !skip it anyway end if c c handle dimension types, if the read function found not expandable c strings, it dumps them in the .*_name fields c try to expand these now c 12 if(des_rec_fils(i_des).ent_type .eq. enttyp_map) goto 141 do kk=1,max_dimension if(.not. des_rec_fils(i_des).rep.dim(kk).low_is_star) then if(des_rec_fils(i_des).rep.dim(kk).low_name.dsc$w_maxstrlen 1 .ne. 0) then istat = dix_eval_express_int(control, 1 des_rec_fils(i_des).rep.dim(kk).low_name, 1 resval,errline,.true.) if(istat) then des_rec_fils(i_des).rep.dim(kk).low = resval else if(.not. quiet) then nke = dix_util_get_len_fu(errline) call dix_message(control,%val(istat),errline(1:nke)) endif goto 99 endif end if if(des_rec_fils(i_des).rep.dim(kk).high_name.dsc$w_maxstrlen 1 .ne. 0) then istat = dix_eval_express_int(control, 1 des_rec_fils(i_des).rep.dim(kk).high_name, 1 resval,errline,.true.) if(istat) then des_rec_fils(i_des).rep.dim(kk).high = resval else if(.not. quiet) then nke = dix_util_get_len_fu(errline) call dix_message(control,%val(istat),errline(1:nke)) endif goto 99 endif end if end if des_rec_fils(i_des).rep.dim(kk).idx = 1 des_rec_fils(i_des).rep.dim(kk).low end do C c 141 ent_type = des_rec_fils(i_des).ent_type size = des_rec_fils(i_des).size var_field = (des_rec_fils(i_des).flags .and. 1 des_flag_is_variable) .ne. 0 c c Select some special cases c c if(ent_type .eq. enttyp_structure) then c c Structure, c 1. build new prefix (include new structure name) c 2. Remember the i_des for the structure c 3. since a structure can have a repeat count, c remember the repeat count c c deep_structure = deep_structure + 1 c c Remember current prefix length (for truncating on endstructure) c save_struct(deep_structure).nk_p = nkar_prefix save_struct(deep_structure).file_line = i_des save_struct(deep_structure).rep = des_rec_fils(i_des).rep save_struct(deep_structure).old_offset= pointer_bit_offset pointer_bit_offset = 0 c nkar1 = des_rec_fils(i_des).nam_len prefix_line(nkar_prefix+1:nkar_prefix+nkar1) = 1 des_rec_fils(i_des).name nkar_prefix = nkar_prefix + des_rec_fils(i_des).nam_len c c Remember nkar_prefix (for rebuilding dimension on endstructure) c save_struct(deep_structure).nk_r = nkar_prefix call dix_des_insert_indices(control,prefix_line, 1 save_struct(deep_structure).rep,nkar_prefix) if(des_rec_fils(i_des).nam_len .gt. 0) then nkar_prefix = nkar_prefix + 1 prefix_line(nkar_prefix:nkar_prefix) = '.' save_struct(deep_structure).empty_name = .false. else save_struct(deep_structure).empty_name = .true. endif goto 10 elseif(ent_type .eq. enttyp_endstructure) then c c endstructure, if repeat count exceeded than all ok c if not exceeded skip back file to correct line c if(dix_des_set_next(save_struct(deep_structure).rep)) then c c More repeating of structure, so trunctate prefix to point just before c repeat counts, and rebuild repeat count c and then set i_Des to the line of the corresponding structure c since label 10 will increase i_des before executing, the first c description to be executed will be the first line after the c corresponding structure c nkar_prefix = save_struct(deep_structure).nk_r call dix_des_insert_indices(control,prefix_line, 1 save_struct(deep_structure).rep,nkar_prefix) if(.not. save_struct(deep_structure).empty_name) then nkar_prefix = nkar_prefix + 1 prefix_line(nkar_prefix:nkar_prefix) = '.' endif i_des = save_struct(deep_structure).file_line else c c Repeat count exhausted, so truncate prefix length to previous length c if(save_struct(deep_structure).old_offset .ne. 0) then bit_offset = save_struct(deep_structure).old_offset endif nkar_prefix = save_struct(deep_structure).nk_p deep_structure = deep_structure-1 end if c prefix_line(nkar_prefix+1:) = ' ' goto 10 c elseif (ent_type .eq. enttyp_map) then c c Map statement c 1. Set bit_offset back to the one it was during the UNION statement c 2. Remember the i_des of this MAP (so we will see the last MAP again) c 3. check for override, if so execute without questions c 4. check for dependend part. c 4.1 if not, execute map c 4.2 if there is a dependend part c 4.2.1 if depandant part=*, remember in IDX_MATCH_ALL, and skip c until corresponding ENDMAP c compute dependend value, and compare to range given c 4.2.1 if match, execute c 4.2.2 if no match, skip until corresponding ENDMAP c bit_offset = save_union(deep_union).beg_offset save_union(deep_union).idx_last_map = i_des deep_map = deep_map + 1 c c If override is set, do not check the dependend field c if(save_union(deep_union).override) goto 544 c c See if dependend map, if so the name field contains the dependend string c format c MAP name=value[,value...] c where value=begin_value[:end_value] c c if(des_rec_fils(i_des).rep.dim(1).low_name.dsc$w_maxstrlen 1 .ne. 0) then c c there is a dependend field c if(des_rec_fils(i_des).rep.dim(1).low_is_star) then c c It is a match if no other map matches, so remember this index c save_union(deep_union).idx_match_all = i_des else c c It is a normal dependend field, try to locate c call dix_util_copy_string( 1 des_rec_fils(i_des).rep.dim(1).low_name,wnam) c nk = 1 des_rec_fils(i_des).rep.dim(1).low_name.dsc$w_maxstrlen c c First try to locate the fieldname itself c call dix_util_clear_descr(fldnam,.false.) c c See if the expresion is a fieldname , c we must do this to get the possible field values c fldnam will point to this list (or be empty) c c p_des_recs = table.address do k=table.count,1,-1 call dix_des_get_des_1(%val(table.address),k,des_rec_w,nam) if(nam .eq. wnam) then fldnam = des_rec_w.fldnam goto 431 else p_des_rec_fil = des_rec_w.link_back if(wnam .eq. des_rec_fil.name) then fldnam = des_rec_w.fldnam goto 431 endif endif end do c c Evaluate the expression, the result should be integer*4 c 431 istat= dix_eval_expression(control,wnam(1:nk),eval_val, 1 .false.,errline,.true.,is_symbol) if(istat) then if(eval_val.type .ne. symb_typ_int) then if(.not. quiet) then call dix_message(control,dix_msg_mapnotint,wnam(1:nk)) endif goto 99 endif c c Got the value of the dependend field c Check the range(s) to check c des_rec.bit_offset = 0 des_rec.size = min(32,des_rec.size) id_wnam = 0 do while(str$element(wnam,id_wnam,',', 1 des_rec_fils(i_des).rep.dim(1).high_name)) c id_wnam = id_wnam + 1 nk = dix_util_get_len(wnam) c c Now we have a range in WNAM (format begin_value[:end_value] c if(dix_des_check_range(control,wnam(1:nk),fldnam, 1 low_lim,hig_lim,errline)) then c c Evaluation went fine, Check if dependand value is in range c if(eval_val.ival .ge. low_lim .and. 1 eval_val.ival .le. hig_lim) goto 544 else c c We had a conversion error somewhere c if(.not. quiet) then nke = dix_util_get_len_fu(errline) call dix_message(control,dix_msg_general, 1 errline(1:nke)) endif goto 99 endif enddo else c c Could not evaluate dependend field c if(.not. quiet) then nke = dix_util_get_len_fu(errline) call dix_message(control,%val(istat),errline(1:nke)) call dix_message(control,dix_msg_mapnfnd,wnam(1:nk)) endif goto 99 endif endif c c No match, Skip until next corresponding endmap description c save_deep_map = deep_map do while(des_rec_fils(i_des+1).ent_type .ne. enttyp_endmap 1 .or. deep_map .ne. save_deep_map) i_des = i_des + 1 if(des_rec_fils(i_des).ent_type .eq. enttyp_map) 1 deep_map = deep_map + 1 if(des_rec_fils(i_des).ent_type .eq. enttyp_endmap) 1 deep_map = deep_map - 1 end do goto 10 !not used yet end if c c We have a match, or no dependend field , or override c 544 save_union(deep_union).used = .true. goto 10 !all done c elseif (ent_type .eq. enttyp_endmap) then c c End map, remember biggest bit_offset c deep_map = deep_map-1 c c If override, we were executing a previous map, so skip to end union now c if(save_union(deep_union).override) 1 i_des = save_union(deep_union).idx_end_union-1 c c Else remember the biggest bit_offset of all MAP's c save_union(deep_union).end_offset = 1 max(save_union(deep_union).end_offset,bit_offset) goto 10 !all done elseif (ent_type .eq. enttyp_union) then c c New union c Remember a lot of things c deep_union = deep_union + 1 save_union(deep_union).beg_offset = bit_offset save_union(deep_union).end_offset = bit_offset save_union(deep_union).idx_last_map = 0 save_union(deep_union).idx_match_all = 0 save_union(deep_union).idx_end_union = 0 save_union(deep_union).used = .false. save_union(deep_union).override = .false. goto 10 !all done elseif (ent_type .eq. enttyp_endunion) then c c End union, see if any of the MAP's matched, c If not, try to skip back to the match_all map (MAP *) c if that is not found, take the last map in the union c if(.not. save_union(deep_union).used) then c c No map of this union has been used c 1. remember IDX of end_union c 2. Set override c 3. skip back to a valid MAP c save_union(deep_union).idx_end_union = i_des i_des = save_union(deep_union).idx_match_all if(i_des .eq. 0) i_des = save_union(deep_union).idx_last_map !rewind a bit i_des = i_des - 1 !so we find the MAP again save_union(deep_union).override = .true. else c c Some map has beep used, now set the bit_offset to the max of all MAP's found c bit_offset = save_union(deep_union).end_offset deep_union = deep_union-1 end if goto 10 !all done elseif(ent_type .eq. enttyp_abort) then c c The fldnam can contain an optional expression c it if is there and it evaluates to true, abort c istat = 1 if(des_rec_fils(i_des).fldnam.dsc$w_maxstrlen .gt. 0) then istat= dix_eval_expression(control, 1 des_rec_fils(i_des).fldnam,eval_val, 1 .false.,errline,.true.,is_symbol) if(istat) then if(eval_val.type .eq. symb_typ_log) then istat = eval_val.lval else call dix_message(control,dix_msg_notlog, 1 des_rec_fils(i_des).fldnam) istat = 0 !ignore endif endif endif c if(istat) then nk = des_rec_fils(i_des).nam_len if(nk .gt. 0) call dix_message(control,dix_msg_desabort, 1 des_rec_fils(i_des).name(1:nk)) goto 99 endif elseif(ent_type .eq. enttyp_field) then goto 10 elseif(ent_type .eq. enttyp_endfield) then if(mod(bit_offset,bits_per_byte) .ne. 0) then bit_offset = bit_offset + bits_per_byte- 1 mod(bit_offset,bits_per_byte) end if goto 10 elseif(ent_type .eq. enttyp_position) then ioff = des_rec_fils(i_des).rep.dim(1).high if(iand(des_rec_fils(i_des).flags,des_flag_field_mode).eq.0) then c c Not in field node, multiply by bits_per_byte c ioff = ioff * bits_per_byte endif c c If relative(or value negative), add/sub from current offset c If not just set bit_offset c if(iand(des_rec_fils(i_des).flags,des_flag_is_relative).ne.0 .or. 1 ioff .lt. 0) then bit_offset = max(0,bit_offset + ioff) else bit_offset = ioff endif goto 10 elseif(ent_type .eq. enttyp_range) then range_save_bit_offset = bit_offset bit_offset = des_rec_fils(i_des).rep.dim(1).low*bits_per_byte max_pos = min(nb_data, 1 des_rec_fils(i_des).rep.dim(1).high) in_range = .true. goto 10 elseif(ent_type .eq. enttyp_endrange) then in_range = .false. bit_offset = range_save_bit_offset goto 10 elseif(ent_type .eq. enttyp_pointer) then c c Now find the first field that that uses the pointer in link_offset c do k=1,table.count call dix_des_get_des_1(%val(table.address),k,des_rec_w,nam) c c See if my link_offset equals the link_back of the found record c if(des_rec_fils(i_des).link_pointer.eq.des_rec_w.link_back) then c c We found the field, get the bitoffset c Get the value from the data c call dix_util_copy_bits(size,bit_offset,data,ipos,4) pointer_bit_offset = bit_offset + size !remember to jump back new_bit_offset = des_rec_w.bit_offset + ipos*bits_per_byte ent_type = enttyp_int goto 75 endif enddo goto 10 !should not happen end if c c Normal case, just normal type c 75 if(in_range) then if(bit_offset .ge. max_pos*bits_per_byte) goto 76 else if(bit_offset .ge. nb_data*bits_per_byte) goto 76 endif c c For var data, use type to determine real size c if(var_field) then size = nb_data*bits_per_byte-bit_offset call dix_des_get_real_size(ent_type,size, 1 data(bit_offset/bits_per_byte+1), 1 des_rec_fils(i_des).lun_translate,control) end if c nk = des_rec_fils(i_des).nam_len !and length nam(1:nk) = des_rec_fils(i_des).name !compute name is_filler = (des_rec_fils(i_des).flags .and. 1 des_flag_is_filler) .ne. 0 c is_zero = dix_con_is_filler(control,size,bit_offset,ent_type, 1 data,des_rec_fils(i_des).lun_translate) c call dix_des_insert_indices(control,nam, 1 des_rec_fils(i_des).rep,nk) !Add repeat counts c if(.not. is_filler) then c c Compute total size of name (prefix + name + indices) c nkar1 = nk + nkar_prefix if(des_rec_fils(i_des).p_link_rec .ne. 0) then if(nkar1+1 .gt. max_size) max_size = nkar1+1 else if(nkar1 .gt. max_size) max_size = nkar1 endif c c See if the name still fits in the name area c if(nkar1 .gt. (fieldnames.allocated - fieldnames.size))then c c Does not fit, expand the area c by by 1024 bytes, but minimally 2*nk c compute new size, and get the memory c nb = max(2*nkar1,1024) + fieldnames.allocated call get_vm(control,nb,ptr,vm_zone,.false.,'DES_NAMES') c c Copy the old data to the new area(if present) c if(fieldnames.address .ne. 0) then c c Copy it c call dix_util_copy(fieldnames.size, 1 %val(fieldnames.address),%val(ptr)) c c Now adjust all names. The offset has changed, compensate fo new base address c p_des_recs = table.address do l=1,table.count des_recs(l).nam.dsc$a_pointer = 1 des_recs(l).nam.dsc$a_pointer+ptr-fieldnames.address end do c c Free the previous part c call free_vm(control,fieldnames.allocated, 1 fieldnames.address,vm_zone) c c And set new values for ptr/allocated size c endif fieldnames.address = ptr fieldnames.allocated = nb endif c c Now insert the name c des_rec.nam.dsc$w_maxstrlen = nkar1 des_rec.nam.dsc$a_pointer = fieldnames.size + fieldnames.address c c First the prefix c ptr = des_rec.nam.dsc$a_pointer call dix_util_copy(nkar_prefix,%ref(prefix_line),%val(ptr)) ptr = ptr + nkar_prefix call dix_util_copy(nk,%ref(nam),%val(ptr)) fieldnames.size = fieldnames.size + nkar1 c c Now create the descriptor. We only store the offset here, c if later in this run the data needs to be copied, do do not need to c adapt the offsets. c at the end we add the (then valid) offset to the .dsc$a_pointer c des_rec.fldnam = des_rec_fils(i_des).fldnam des_rec.ent_type = ent_type des_rec.size = size des_rec.link_back = %loc(des_rec_fils(i_des)) des_rec.bit_offset = bit_offset flags = des_rec_fils(i_des).flags if(is_zero) flags = flags .or. des_flag_compressed des_rec.flags = flags c des_rec.min_val = des_rec_fils(i_des).min_val des_rec.max_val = des_rec_fils(i_des).max_val des_rec.p_link_rec = des_rec_fils(i_des).p_link_rec des_rec.lun_translate = des_rec_fils(i_des).lun_translate c c Now see if pad_value <>0 c des_rec.pad_value = 0 if(.not. is_zero) n_desnc = n_desnc + 1 line_nr = line_nr + 1 c c Now add description to list of descriptions c call dix_util_insert_table(control, 1 table,des_rec,50,vm_zone,'DES_REC') end if c if(new_bit_offset .ge. 0) then bit_offset = new_bit_offset new_bit_offset = -1 else bit_offset = bit_offset + size endif c c Now see about the fill quantity c if(des_rec_fils(i_des).pad_value .gt. 0) then c c We have a pad value defined. c pad_value = des_rec_fils(i_des).pad_value if(mod(bit_offset,pad_value) .ne. 0) then c c Was not aligned, so we need padding, do it and remember pad_value c k = bit_offset bit_offset = pad_value*(bit_offset/pad_value+1) k = bit_offset-k c c If it was not a filler, save the pad value in the des_recs c if(.not. is_filler) then p_des_recs = table.address des_recs(table.count).pad_value = k endif endif endif c if(bit_offset/bits_per_byte .gt. max_data) 1 max_data = bit_offset/bits_per_byte c c Check for repeat count c if((des_rec_fils(i_des).flags .and. des_flag_has_limit) .ne. 0) then c c Check if the limit has been reached c make expresssion as name//limit_value c this should make an expressoin with result logical c wnam = des_rec_fils(i_des).name nk = des_rec_fils(i_des).nam_len call dix_append(nk,wnam,des_rec_fils(i_des).limit_value) c istat= dix_eval_expression(control,wnam(1:nk),eval_val, 1 .false.,errline,.true.,is_symbol) if(eval_val.type .ne. symb_typ_log) then call dix_message(control,dix_msg_notlog,wnam(1:nk)) res = .false. else res = eval_val.lval endif if(res) then c c Check if the field has a repeat count itself, c if so skip the repeat c if(des_rec_fils(i_des).rep.has_dims) goto 10 c c No, now set for the next end structure and skipt that one's repeat c goto 80 endif endif if(dix_des_set_next(des_rec_fils(i_des).rep)) then goto 75 end if goto 10 c c Finished c 76 if(in_range .or. deep_map .gt. 0) goto 10 goto 90 c c Search for the next end structure structure c Find the next endstructure c 80 if(deep_structure .eq. 0) goto 10 !should not happen level = 0 do kk=i_des+1,n_des if(des_rec_fils(kk).ent_type.eq.enttyp_structure)level = level + 1 if(des_rec_fils(kk).ent_type.eq.enttyp_endstructure)then if(level .gt. 0) then level = level - 1 else c c Set the repeart to exit, and set pointer to end_structure c do k=1,max_dimension save_struct(deep_structure).rep.dim(k).idx = 1 save_struct(deep_structure).rep.dim(k).high end do i_des = kk goto 12 endif end if end do c c Not found, should not happen c goto 10 c c normal exit c 90 dix_des_expand_1 = .true. 99 call dix_eval_free_value(eval_val) c c See if there are fields with bit_overlap c if so, set for those fields the dependency flag c p_des_recs = table.address do k=1,table.count c c Get the bit_range of this element c do l=k+1,table.count if(dix_util_overlap(des_recs(k).bit_offset, 1 des_recs(k).size, 1 des_recs(l).bit_offset, 1 des_recs(l).size)) then c c We have overlap, set both field to dependancy c des_recs(k).flags = des_recs(k).flags .or. 1 des_flag_has_dependancy des_recs(l).flags = des_recs(l).flags .or. 1 des_flag_has_dependancy c c endif end do end do c c The size field of the _message type is used to c signal a "already displayed" value c Set the size back to 0 for the next expand c do k=1,n_des if(des_rec_fils(k).ent_type .eq. enttyp_message) then des_rec_fils(k).size = 0 endif end do return end function dix_des_check_range(control,wnam,fldnam, 1 low_lim,hig_lim,errline) implicit none c c Evalute a range to low_lim:high_lim c where entry = begin[:end] c include 'dix_def.inc' record /control/ control !:i: control block character*(*) wnam !:i: the string to evaluate character*(*) fldnam !:i: the (optional) fieldnames integer*4 low_lim !:o: first value integer*4 hig_lim !:o: second value character*(*) errline !:o: the error string integer*4 dix_des_checK_range !:f: result c# integer*4 ipos,istat c integer*4 dix_des_check_value ipos = index(wnam,':') if(ipos .eq. 0) ipos = len(wnam)+1 c c Expand the first value c evaluate the expression (result must be integer) c istat = dix_des_check_value(control, 1 wnam(1:ipos-1),fldnam,low_lim,errline) if(ipos .gt. len(wnam)) then c c Only one value , set the high value equal to the low one c hig_lim = low_lim else c c We have format begin_value:end_value c now expand the rest c if(istat) istat = dix_des_check_value(control, 1 wnam(ipos+1:),fldnam,hig_lim,errline) endif dix_des_checK_range = istat return end function dix_des_check_value(control,wnam,fldnam,value,errline) implicit none c c Tey to evaluate wnam to an integer. If this failes check the fieldvalues c include 'dix_def.inc' record /control/ control !:i: the control block character*(*) wnam !:i: the expression character*(*) fldnam !:i: the list of fieldvalues integer*4 value !:o: the value character*(*) errline !:o: error message logical dix_des_check_value !:f: result c# integer*4 dix_Eval_express_int integer*4 dix_util_find_field integer*4 istat c istat = dix_eval_express_int(control,wnam,value,errline,.true.) c if(.not. istat .and. len(fldnam) .gt. 0) then c c We had a conversion error, try to use one of the fields c if the first expression is a fieldname and it has fields c istat = dix_util_find_field(wnam,fldnam,value) endif dix_des_check_value = istat return end c function dix_des_find_par(control,name,resval) implicit none c c Try to find a parameter in a des_rec c include 'dix_def.inc' record /control/ control !:i: control structure character*(*) name !:i: name of param integer*4 resval !:o: result value integer*4 dix_des_find_par !:f: function result c# c record /file_info/ file pointer (p_file,file) c record /des_expanded/ des_expanded pointer (p_des_Expanded,des_expanded) c record /des_info/ des_info pointer (p_des_info,des_info) c record /param/ pars(*) pointer (p_pars,pars) c integer*4 k c dix_des_find_par = .false. resval = 0 c p_file = control.cur_file if(p_file .eq. 0) goto 90 c p_des_expanded = file.cur_des if(p_des_expanded .eq. 0) goto 90 c p_des_info = des_expanded.p_des_info if(p_des_info .eq. 0) goto 90 c p_pars = des_info.parameters.address c do k=1,des_info.parameters.count if(pars(k).name .eq. name) goto 20 end do goto 90 c 20 resval = pars(k).value dix_des_find_par = .true. c 90 return end c function dix_des_find_field(control,name,des_rec,set_dep,ptr,in_vfc) implicit none c c Try to find a field name from the list of expanded des c A fully qualifier field name is c filetag\descriptiontag\name c both tags default to the current (file or description) c if only one \ is found, it is interpreted as c filetag\filename with the current description is used c include 'dix_def.inc' record /control/ control !:i: control structure character*(*) name !:i: the name to find record /des_rec/ des_rec !:o: the resulting des_rec logical set_dep !:i: if found, do we set dependency flag? logical field_mode !:o: in fieldmode? integer*4 ptr !:o: pointer to file where found logical*4 in_vfc !:i: in vfc data logical*4 dix_des_find_field !:f: result of search c# character*(name_length) namdes integer*4 k,pos_field,ptr_file,ptr_des,ndes c record /des_rec_fil/ des_rec_fil pointer (p_des_rec_fil,des_rec_fil) c record /file_info/ file pointer (p_file,file) c record /des_expanded/ des_expanded pointer (p_des_expanded, des_expanded) c record /des_rec/ des_recs(*) pointer (p_des_recs,des_recs) c logical dix_des_find_file_des c dix_des_find_field = .false. c c Set pointers right c if(dix_des_find_file_des(control,name,ptr_file,ptr_des,pos_field)) then p_file = ptr_file p_des_expanded = ptr_des c c Check for expansion c call dix_des_expand(control,des_expanded,file,.true.) C if(in_vfc) then ndes = des_expanded.table_vfc.count p_des_recs = des_expanded.table_vfc.address else ndes = des_expanded.table_nor.count p_des_recs = des_expanded.table_nor.address endif c if(des_expanded.expand_error) ndes = 0 c field_mode = .false. do k=1,ndes c c Get the (expanded) name of the field c the also contains structure info c e.g. str1.str2.field(d1,d2) c We need the field part c namdes = ' ' call dix_util_copy(des_recs(k).nam.dsc$w_maxstrlen, 1 %val(des_recs(k).nam.dsc$a_pointer),%ref(namdes)) if(namdes .eq. name(pos_field:)) goto 80 end do c c Did not find the name, now try backlink to the original c field specification (the one in the description file) c do k=des_expanded.table_nor.count,1,-1 p_des_rec_fil = des_recs(k).link_back namdes = des_rec_fil.name(1:des_rec_fil.nam_len) if(name(pos_field:) .eq. namdes) goto 80 end do c c Could not find it, now check for special values c if(name(pos_field:) .eq. '$RECORDSIZE') then des_rec.ent_type = enttyp_int des_rec.bit_offset = bits_per_byte*(%loc(file.data.nb_data) - 1 %loc(file.data.data_rec)) des_rec.size = bits_per_byte*sizeof(file.data.nb_data) goto 85 endif goto 90 c c Found the field, return des_rec, c if set_dep is true, makr this field as having a dependency c 80 des_rec = des_recs(k) if(set_dep) des_recs(k).flags = 1 des_recs(k).flags .or. des_flag_has_dependancy 85 dix_des_find_field = .true. ptr = p_file endif c 90 return end function dix_des_find_file_des(control,name,ptr_file,ptr_des,pos_field) implicit none c c Try to find a field name from the list of expanded des c A fully qualifier field name is c filetag\descriptiontag\name c both tags default to the current (file or description) c if only one \ is found, it is interpreted as c filetag\filename with the current description is used c include 'dix_def.inc' record /control/ control !:i: control structure character*(*) name !:i: the name to find integer*4 ptr_file !:o: pointer to file where found integer*4 ptr_des !:o: pointer to description found integer*4 pos_field !:o: position in name of start of fieldname logical*4 dix_des_find_file_des !:f: result of search c# integer*4 k,pos_descr c record /file_info/ file pointer (p_file,file) c record /des_expanded/ des_expanded pointer (p_des_expanded,des_expanded) c dix_des_find_file_des = .false. c c Set pointers right c pos_field = index(name,'\') if(pos_field .ne. 0) then pos_descr = index(name(pos_field+1:),'\') if(pos_descr .ne. 0) then k = pos_descr + pos_field pos_descr = pos_field pos_field = k else pos_descr = pos_field endif c c Name had a file tag, now search all files for the tag c if(pos_descr .eq. 1) then p_file = control.cur_file else p_file = control.top_file do while(p_file .ne. 0) if(file.handle .eq. name(1:pos_descr-1)) goto 10 p_file = file.link.forw end do endif else p_file = control.cur_file pos_descr = 0 endif c c We have found the file (either by default ot explicit) c Now try to find the description c 10 ptr_file = p_file if(p_file .eq. 0) goto 90 c if(pos_descr .lt. pos_field+1) then p_des_expanded = file.cur_des else c c Find a match for the description c p_des_expanded = file.top_des do while(p_des_expanded .ne. 0) if(des_expanded.handle .eq. name(pos_field+1:pos_descr-1)) goto 20 end do endif 20 pos_field = pos_field + 1 if(p_des_expanded .eq. 0) goto 90 c ptr_des = p_des_expanded dix_des_find_file_des = .true. c 90 return end c subroutine dix_des_get_fieldname(control,idx,mask,name,nkar) implicit none c c Return fieldnames c return the idx'th occurrence of the fieldname that matches "mask" c include 'dix_def.inc' record /control/ control !:i: control structure integer*4 idx !:i: the idx'th match character*(*) mask !:i: mask character*(*) name !:o: the name found integer*4 nkar !:o: name length c# record /file_info/ file pointer (p_file,file) c record /des_expanded/ des_expanded pointer (p_des_expanded, des_expanded) c record /des_rec/ des_recs(*) pointer (p_des_recs,des_recs) c integer*4 k,count character*(name_length) namdes c logical str$match_wild c c Search backward c p_file = control.cur_file if(p_file .eq. 0) goto 10 c p_des_expanded = file.cur_des if(p_des_expanded .eq. 0) goto 10 c p_des_recs = des_expanded.table_nor.address c count = 0 do k=1,des_expanded.table_nor.count namdes = ' ' nkar = des_recs(k).nam.dsc$w_maxstrlen call dix_util_copy(nkar,%val(des_recs(k).nam.dsc$a_pointer), 1 %ref(namdes)) if(str$match_wild(namdes(1:nkar),mask)) then count = count + 1 if(count .eq. idx) goto 20 end if end do 10 nkar = 0 namdes = ' ' 20 name = namdes return end c subroutine dix_des_get_real_size(ent_type,size,data,lun,control) implicit none include 'dix_def.inc' c integer*4 ent_type !:i: entry type integer*4 size !:io: input max size, output computed size byte data(*) !:i: the data integer*4 lun !:i: lun for user type record /control/ control c# integer*4 limit,bltyp,k c logical dix_inter_execute c limit = size if (ent_type .eq. enttyp_string) then size = 0 call dix_util_copy(1,data(1),size) size = size+1 size = size*bits_per_byte elseif(ent_type .eq. enttyp_wstring) then size = 0 call dix_util_copy(2,data(1),size) size = size+2 size = size*bits_per_byte elseif(ent_type .eq. enttyp_lstring) then call dix_util_copy(4,data(1),size) size = size+4 size = size*bits_per_byte elseif(ent_type .eq. enttyp_zstring ) then do size=1,limit if(data(size) .eq. 0) goto 311 end do size = limit 311 continue size = size*bits_per_byte elseif(ent_type .eq. enttyp_hstring) then do size=1,limit if(data(size) .lt. 0) goto 312 end do size = limit 312 continue size = size*bits_per_byte elseif(ent_type .eq. enttyp_diskmap) then bltyp = 0 call lib$movc3(2,data,bltyp) bltyp = ishft(bltyp,-14) if(bltyp .eq. 0) then size = 2 elseif(bltyp .eq. 1) then size = 4 elseif(bltyp .eq. 2) then size = 6 elseif(bltyp .eq. 3) then size = 8 endif size = size*bits_per_byte elseif(ent_type .eq. enttyp_acl) then size = 0 call dix_util_copy(1,data(1),size) size = size*bits_per_byte elseif(ent_type .eq. enttyp_user) then call dix_inter_execute(control,'SIZE',lun, 1 0,' ',data(1),size, 1 k,size,size) end if if(size .gt. limit) size = limit return end function dix_des_set_next(rep) implicit none c c Set the next iteration from tables c include 'dix_def.inc' record /repeat/ rep !:io: repeat structure logical*4 dix_des_set_next !:F: function result c# integer*4 kk c kk = 1 dix_des_set_next = .true. 10 if(rep.dim(kk).idx .lt. rep.dim(kk).high) then rep.dim(kk).idx = rep.dim(kk).idx+1 else rep.dim(kk).idx = rep.dim(kk).low if(kk .lt. max_dimension) then kk = kk + 1 goto 10 end if dix_des_set_next = .false. end if return end subroutine dix_des_insert_indices(control,text,rep,nk) implicit none c c Insert the dimension (if present) to the name c integer*4 control character*(*) text include 'dix_def.inc' record /repeat/ rep !:i: repeat integer*4 nk !:io: printed length c# integer*4 k,nk1 c do k=1,max_dimension if(rep.dim(k).high .gt. rep.dim(k).low) goto 10 end do goto 90 10 text(nk+1:nk+1) = '(' nk = nk+1 do k=1,max_dimension if(rep.dim(k).high .gt. rep.dim(k).low) then c call sys$fao('!SL',nk1,text(nk+1:),%val(rep.dim(k).idx)) call dix_con_type_intasc(4,rep.dim(k).idx,enttyp_int, 1 text(nk+1:),nk1,control) nk = nk+nk1+1 text(nk:nk) = ',' end if end do text(nk:nk) = ')' 90 return end subroutine dix_des_get_des_1(des_recs,i_des,des_rec,name) implicit none c c Get the descriptor entry from the list c fill in the name too c include 'dix_def.inc' c record /des_rec/ des_recs(*) !:i: the list of (expanded) des_recs integer*4 i_des !:i: the wanted one record /des_rec/ des_rec !:o: the selected des_rec character*(*) name !:o: and its name c# integer*4 nk c des_rec = des_recs(i_des) name = ' ' nk = min(des_rec.nam.dsc$w_maxstrlen,len(name)) call dix_util_copy(nk,%val(des_rec.nam.dsc$a_pointer),%ref(name)) return end function dix_des_get_range(control,range,min_val,max_val,nb) implicit none c c Get range values c integer*4 control character*(*) range !:i: the text integer*4 min_val !:o: min value integer*4 max_val !:o: max value integer*4 nb !:i: size of data (in bits) logical*4 dix_des_get_range !:f: result c# integer*4 ipos integer dix_con_int_ascint c dix_des_get_range = .false. c ipos = index(range,':') if(ipos .eq. 0) goto 90 c if(.not.dix_con_int_ascint(range(1:ipos-1),min_val,nb,' ', 1 0,0,control,.false.))goto 90 if(.not.dix_con_int_ascint(range(ipos+1: ),max_val,nb,' ', 1 0,0,control,.false.))goto 90 if(min_val .ge. max_val) goto 90 dix_des_get_range = .true. 90 return end function dix_des_match_qual(typ,match_str,endpos,min_len) implicit none c character*(*) typ !:i: the text to be matched character*(*) match_str !:i: the text to match against integer*4 endpos !:o: max length integer*4 min_len !:i: min length needed to match logical dix_des_match_qual !:f: function result c# integer str$find_first_in_set c endpos = str$find_first_in_set(typ,'/= ') c dix_des_match_qual = endpos-1 .ge. min_len .and. 1 typ(1:endpos-1) .eq. match_str(1:endpos-1) return end subroutine dix_des_display_width(control,des_info,fnam,nk,width) implicit none c c make a display for the desciptor name c include 'dix_def.inc' record /control/ control !:i: control structure record /des_info/ des_info !:i: des file structure character*(*) fnam !:o: name integer*4 nk !:o: length of fnam integer*4 width !:i: max width c# call dix_des_display(control,des_info,fnam,nk,.false.) if(nk .gt. width) then call dix_des_display(control,des_info,fnam,nk,.true.) endif return end subroutine dix_des_display(control,des_info,fnam,nk,short) implicit none c c make a display for the desciptor name c include 'dix_def.inc' record /control/ control !:i: control structure record /des_info/ des_info !:i: des file structure character*(*) fnam !:o: name logical short !:i: short format? integer*4 nk !:o: length of fnam c# if(des_info.in_library .eq. des_in_userlib) then if(short) then fnam = 'USERLIB('//des_info.fnam(1:des_info.nk_fnam)//')' nk = 8 + des_info.nk_fnam + 1 else fnam = control.userlib_name(1:control.nk_userlib)// 1 '('//des_info.fnam(1:des_info.nk_fnam)//')' nk = control.nk_userlib + 1 + des_info.nk_fnam + 1 endif elseif(des_info.in_library .eq. des_in_syslib) then if(short) then fnam = 'SYSLIB('//des_info.fnam(1:des_info.nk_fnam)//')' nk = 7 + des_info.nk_fnam + 1 else fnam = control.syslib_name(1:control.nk_syslib)// 1 '('//des_info.fnam(1:des_info.nk_fnam)//')' nk = control.nk_syslib + 1 + des_info.nk_fnam + 1 endif else fnam = des_info.fnam nk = des_info.nk_fnam endif return end function dix_des_find_des(control,name,in_library,ptr) implicit none c c Find a descriptor from the list of loaded descriptors c include 'dix_def.inc' record /control/ control !:i: control structure character*(*) name !:i: name to find logical in_library !:o: in sys/user-library/file integer*4 ptr !:o: the memtab lun logical dix_des_find_des !:f: function result c# integer*4 istat logical dix_des_find_mod_glo c istat = dix_des_find_mod_glo(control.top_descr, 1 name,in_library,ptr) if(istat) then call dix_main_print_debug(control,debug_des, 1 'Descr found for '//name) endif dix_des_find_des = istat return end function dix_des_find_des_file(file,name,in_library) implicit none include 'dix_def.inc' c c Find the description from the des's linked to a file c record /file_info/ file !:i: the file structure character*(*) name !:i: the name to find logical in_library !:o: where found integer*4 ptr !:o: memtab lun logical dix_des_find_des_file !:f: function result c# logical dix_des_find_mod c dix_des_find_des_file = dix_des_find_mod(file.top_des, 1 name,in_library,ptr) c return end function dix_des_find_mod_glo(top,name,in_library,ptr) implicit none include 'dix_def.inc' c c Find module in global chained list c integer*4 top !:i: top link character*(*) name !:i: name logical in_library !:o: where found integer*4 ptr !:o: memtab_lun logical dix_des_find_mod_glo!:f: function result c# c record /des_info/ des_info pointer (p_des_info, des_info) c dix_des_find_mod_glo = .false. p_des_info = top do while(p_des_info .ne. 0) if(des_info.in_library .eq. in_library) then if(name .eq. des_info.fnam) then ptr = p_des_info dix_des_find_mod_glo = .true. goto 90 endif endif p_des_info = des_info.link.forw end do 90 return end function dix_des_find_mod(top,name,in_library,ptr) implicit none include 'dix_def.inc' c c Find module in file chained list c integer*4 top !:i: top link character*(*) name !:i: name logical in_library !:o: where found integer*4 ptr !:o: memtab_lun logical dix_des_find_mod!:f: function result c# c record /des_expanded/ des_expanded pointer (p_des_expanded, des_expanded) c record /des_info/ des_info pointer (p_des_info,des_info) c dix_des_find_mod = .false. p_des_expanded = top do while(p_des_expanded .ne. 0) p_des_info = des_expanded.p_des_info if(des_info.in_library .eq. in_library) then if(name .eq. des_info.fnam) then ptr = p_des_info dix_des_find_mod = .true. goto 90 endif endif p_des_Expanded = des_Expanded.link.forw end do 90 return end function dix_des_get_qualifier(control,line,nkar,ipos, 1 p_link,vm_zone, 1 trans_override,no_display,range_data,user,case, 1 nk_limit_value,limit_value,readonly,is_vfc, 1 relative,zero_fill,exponent,fraction,leftjust) implicit none c c Parse the file[/key=number]/[compute=string] part c include 'dix_def.inc' record /control/ control character*(*) line !:io: the line integer*4 nkar !:IO: length of the line integer*4 ipos !the / pos integer*4 p_link !:io: the pointer to the link record record /vm_zone/ vm_zone !:i: the zone if to get the data from integer*4 trans_override !:io: override radix logical*4 no_display !:io: the nodisplay flag character*(*) range_data !:o: range data logical*4 user !:o: user defined? integer*4 case !:o: upper/lower case found integer*4 nk_limit_value !:o: limit value character*(*) limit_value !:o: limit value logical*4 readonly !:o: readonly field? logical*4 is_vfc !:o: vfc element? logical*4 relative !:o: relative set logical*4 zero_fill !:o: decimal:zero_fill specified? logical*4 exponent !:o: decimal:exponent allowed logical*4 leftjust !:o: decimal:left just logical*4 fraction !:o: decimal:fraction allowed c# logical dix_des_get_qualifier c record /link_rec/ link_rec pointer (p_link_rec,link_rec) c integer*4 istat,k,endpos,keynr,nk_res,l !,bpos,epos,nk_d integer*4 nk4 character*(max_line_length) res_line !,thisdir character*(max_line_length) work c integer str$find_first_in_set external dix_msg_synterr external dix_msg_invqual external dix_msg_openquote logical dix_des_match_qual integer*4 dix_des_get_p_link c res_line = line(ipos+1:nkar) nk_res = nkar - ipos p_link_rec = p_link istat = 1 if( dix_des_match_qual(res_line,'HEXADECIMAL',endpos,2)) then trans_override = des_flag_translate_hex elseif(dix_des_match_qual(res_line,'OCTAL',endpos,2)) then trans_override = des_flag_translate_oct elseif(dix_des_match_qual(res_line,'BINARY',endpos,2)) then trans_override = des_flag_translate_bin elseif(dix_des_match_qual(res_line,'NODISPLAY',endpos,2)) then no_display = .true. elseif(dix_des_match_qual(res_line,'ZERO_FILL',endpos,2)) then zero_fill = .true. elseif(dix_des_match_qual(res_line,'EXPONENT',endpos,2)) then exponent = .true. elseif(dix_des_match_qual(res_line,'LEFTJUST',endpos,2)) then leftjust = .true. elseif(dix_des_match_qual(res_line,'FRACTION',endpos,2)) then fraction = .true. elseif(dix_des_match_qual(res_line,'VFC',endpos,2)) then is_vfc = .true. elseif(dix_des_match_qual(res_line,'RELATIVE',endpos,3)) then relative = .true. elseif(dix_des_match_qual(res_line,'READONLY',endpos,3)) then readonly = .true. elseif(dix_des_match_qual(res_line,'USER',endpos,2)) then user = .true. elseif(dix_des_match_qual(res_line,'UPPERCASE',endpos,2)) then case = des_flag_case_upper elseif(dix_des_match_qual(res_line,'LOWERCASE',endpos,2)) then case = des_flag_case_lower elseif(dix_des_match_qual(res_line,'LIMIT',endpos,2)) then c c Two formats c 1. /limit=expr c 2. /limit="expres" c if(res_line(endpos:endpos) .ne. '=') goto 80 if(res_line(endpos+1:endpos+1) .ne. '"') then c c Format 1. c k = str$find_first_in_set(res_line(endpos+1:),'/ ') k = endpos + k limit_value =res_line(endpos+1:k-1) nk_limit_value = k-1 - endpos endpos = k else c c Format 2. Now copy all until closing quote c endpos = endpos+2 do while (endpos .le. nk_res) if(res_line(endpos:endpos) .eq. '"') then endpos = endpos + 1 if(endpos .ge. nk_res) goto 7 if(res_line(endpos:endpos) .ne. '"') goto 7 endif nk_limit_value = nk_limit_value + 1 l = nk_limit_value link_rec.link_file(l:l) = res_line(endpos:endpos) endpos = endpos + 1 end do istat = %loc(dix_msg_openquote) goto 81 !no trailing " 7 endpos = endpos endif c c Now make sure the first char is an operator c if(limit_value(1:1) .ne. '>' .and. limit_value(1:1) .ne. '<')then limit_value = '='//limit_value nk_limit_value = nk_limit_value + 1 endif elseif(dix_des_match_qual(res_line,'RANGE',endpos,2)) then k = endpos+1 endpos = str$find_first_in_set(res_line,'/ ') range_data = res_line(k:endpos-1) elseif(dix_des_match_qual(res_line,'MATCH',endpos,2)) then if(res_line(endpos:endpos) .ne. '=') goto 80 k = str$find_first_in_set(res_line(endpos+1:),'/ ') l = -5 if(res_line(endpos+1:endpos+2) .eq. 'EQ') l = 0 if(res_line(endpos+1:endpos+2) .eq. 'GE') l = 1 if(res_line(endpos+1:endpos+2) .eq. 'GT') l = 2 if(res_line(endpos+1:endpos+2) .eq. 'LE') l = -1 if(res_line(endpos+1:endpos+2) .eq. 'LT') l = -2 if(l .eq. -5) goto 80 istat = dix_des_get_p_link(control,p_link_rec,vm_zone) if(.not. istat) goto 90 link_rec.match = l endpos = endpos + k elseif(dix_des_match_qual(res_line,'FILE',endpos,2)) then c c The /FILE= has two syntaxes c a. /file=filename result will be quoted name c b. /file="expression" Result will be string as entered c if(res_line(endpos:endpos) .ne. '=') goto 80 if(res_line(endpos+1:endpos+1) .ne. '"') then c c Format 1. c k = str$find_first_in_set(res_line(endpos+1:),'/ ') k = endpos + k istat = dix_des_get_p_link(control,p_link_rec,vm_zone) if(.not. istat) goto 90 link_rec.link_file = '"'//res_line(endpos+1:k-1)//'"' link_rec.nk_link_file = k-1 - endpos + 2 endpos = k else c c Format 2. Now copy all until closing quote c istat = dix_des_get_p_link(control,p_link_rec,vm_zone) if(.not. istat) goto 90 endpos = endpos+2 do while (endpos .le. nk_res) if(res_line(endpos:endpos) .eq. '"') then endpos = endpos + 1 if(endpos .ge. nk_res) goto 8 if(res_line(endpos:endpos) .ne. '"') goto 8 endif link_rec.nk_link_file = link_rec.nk_link_file + 1 l = link_rec.nk_link_file link_rec.link_file(l:l) = res_line(endpos:endpos) endpos = endpos + 1 end do istat = %loc(dix_msg_openquote) goto 81 !no trailing " 8 endpos = endpos endif elseif(dix_des_match_qual(res_line,'KEY',endpos,2)) then keynr = 0 if(res_line(endpos:endpos) .eq. '=') then k = str$find_first_in_set(res_line(endpos+1:),'/= ') k = k + endpos read(res_line(endpos+1:k-1),2000,err=80) keynr 2000 format(bn,i10) if(keynr .lt. 0 .or. keynr .gt. 255) goto 80 endpos = k endif istat = dix_des_get_p_link(control,p_link_rec,vm_zone) if(.not. istat) goto 90 link_rec.key_nr = keynr elseif(dix_des_match_qual(res_line,'RECORD',endpos,3)) then istat = dix_des_get_p_link(control,p_link_rec,vm_zone) if(.not. istat) goto 90 link_rec.key_nr = -1 elseif(dix_des_match_qual(res_line,'IF',endpos,2)) then c c conditional if c if(res_line(endpos:endpos) .ne. '=') goto 80 endpos = endpos + 1 if(res_line(endpos:endpos) .ne. '"') goto 80 c c Find closing ", but skip "" c istat = dix_des_get_p_link(control,p_link_rec,vm_zone) if(.not. istat) goto 90 endpos = endpos+1 nk4 = 0 do while (endpos .le. nk_res) if(res_line(endpos:endpos) .eq. '"') then endpos = endpos + 1 if(endpos .ge. nk_res) goto 12 if(res_line(endpos:endpos) .ne. '"') goto 12 endif c nk4 = nk4 + 1 work(nk4:nk4) = res_line(endpos:endpos) endpos = endpos + 1 end do istat = %loc(dix_msg_openquote) goto 81 !no trailing " 12 endpos = endpos call dix_util_insert_string(control,link_rec.if_line, 1 vm_zone,work(1:nk4)) c elseif(dix_des_match_qual(res_line,'COMPUTE',endpos,2)) then if(res_line(endpos:endpos) .ne. '=') goto 80 endpos = endpos + 1 if(res_line(endpos:endpos) .ne. '"') goto 80 c c Find closing ", but skip "" c istat = dix_des_get_p_link(control,p_link_rec,vm_zone) if(.not. istat) goto 90 endpos = endpos+1 nk4 = 0 do while (endpos .le. nk_res) if(res_line(endpos:endpos) .eq. '"') then endpos = endpos + 1 if(endpos .ge. nk_res) goto 14 if(res_line(endpos:endpos) .ne. '"') goto 14 endif nk4 = nk4 + 1 work(nk4:nk4) = res_line(endpos:endpos) endpos = endpos + 1 end do istat = %loc(dix_msg_openquote) goto 81 !no trailing " 14 call dix_util_insert_string(control,link_rec.comp_line, 1 vm_zone,work(1:nk4)) endpos = endpos else endpos = str$find_first_in_set(res_line,'/ ') call dix_message(control,dix_msg_invqual,res_line(1:endpos-1)) goto 80 endif c c BLank out the string processed c line(ipos:ipos+endpos-1) = ' ' istat = 1 goto 90 c 80 istat = %loc(dix_msg_synterr) 81 if(p_link_rec .ne. 0) then call free_vm(control,sizeof(link_rec),p_link_rec,vm_zone) p_link_rec = 0 endif 90 p_link = p_link_rec dix_des_get_qualifier = istat return end function dix_des_get_p_link(control,p_link_rec,vm_zone) implicit none c c Create new link_rec, but only if needed c include 'dix_def.inc' record /control/ control !:i: control block record /link_rec/ link_rec !:i: line_rec pointer pointer (p_link_rec,link_rec) record /vm_zone/ vm_zone !:o: zone_id c# integer*4 istat logical dix_des_get_p_link c if(p_link_rec .eq. 0) then call get_vm(control,sizeof(link_rec),p_link_rec,vm_zone, 1 .false.,'LINK_REC') link_rec.magic = magic_link_rec link_rec.nk_link_file = 0 link_rec.key_nr = 0 link_rec.match = 0 endif istat = 1 dix_des_get_p_link =istat return end subroutine dix_des_make_handle(des_info,top_des,des_expanded) implicit none c c Create a handle name from a file name (make sure it's unique) c include 'dix_def.inc' c record /des_info/ des_info !:i: des info block integer*4 top_des !:i: top description pointer record /des_Expanded/ des_expanded !:i: expanded des c# record /des_expanded/ des_exp pointer (p_des_exp,des_exp) c integer*4 icnt,nk,k,bpos,epos,nk_exp character*(max_short_line_length) temp c integer*4 dix_util_get_len logical dix_util_legal_char c c nk = 0 if(des_info.in_library .eq. des_in_file) then c c From file, take filename part of the description file c call dix_util_file_parse(des_info.fnam,'N',bpos,epos) do k=bpos,epos if(dix_util_legal_char(des_info.fnam(k:k),k-bpos+1)) then if(nk .eq. len(des_expanded.handle)) goto 5 nk = nk + 1 des_expanded.handle(nk:nk) = des_info.fnam(k:k) endif end do else c c From library : take the desciption name and remove all non valid chars c do k=1,des_info.nk_fnam if(dix_util_legal_char(des_info.fnam(k:k),k)) then if(nk .eq. len(des_expanded.handle)) goto 5 nk = nk + 1 des_expanded.handle(nk:nk) = des_info.fnam(k:k) endif end do endif 5 des_expanded.nk_handle = nk des_expanded.handle(des_expanded.nk_handle+1:) = ' ' c c Now make sure its unique c icnt = 0 nk_exp = nk 10 p_des_exp = top_des do while(p_des_exp .ne. 0) if(des_expanded.handle .eq. des_exp.handle) then icnt = icnt + 1 call sys$fao('_!UL',nk,temp,%val(icnt)) if(nk_exp+nk .gt. len(des_expanded.handle)) then nk_exp = len(des_expanded.handle) - nk endif des_expanded.handle(nk_exp+1:) = temp(1:nk) des_expanded.nk_handle = nk_exp + nk goto 10 endif p_des_exp = des_exp.link.forw end do des_expanded.handle(des_expanded.nk_handle+1:) = ' ' des_expanded.nk_handle = dix_util_get_len(des_expanded.handle) return end subroutine dix_des_inv_des(control,file) implicit none c c The record changed, set the expand flag for all c desciptions of this file that are not fixed c Set the expanded flag for all descriptions to false c If the description is fixed, we do not need to clear c the expand flag c include 'dix_def.inc' record /control/ control !:i: cotnrol record /file_info/ file !:i: the file control block c# record /des_expanded/ des_expanded pointer (p_des_expanded,des_expanded) c record /des_info/ des_info pointer (p_des_info,des_info) c p_des_expanded = file.top_des c do while(p_des_expanded .ne. 0) c p_des_info = des_expanded.p_des_info if(des_info.fixed .and. file.fixed) then c c Description is fixed, and the file has fixed record length c this means the description is static, and does not change c over the records, so no need to clear the expand flag c if((control.debug .and. debug_expand) .ne. 0) then call dix_main_print_debug(control,debug_expand, 1 'Not clearing expand flag for (fixed) '// 1 des_expanded.handle(1:des_expanded.nk_handle)) endif else if((control.debug .and. debug_expand) .ne. 0) then call dix_main_print_debug(control,debug_expand, 1 'Clearing expand flag for '// 1 des_expanded.handle(1:des_expanded.nk_handle)) endif c des_expanded.is_expanded = .false. endif p_des_expanded = des_expanded.link.forw end do return end subroutine dix_des_inv_des_all(control,des_info) implicit none c c The description changed, set the expand flag for all c desciptions pointing to this des_info record c include 'dix_def.inc' record /control/ control record /des_info/ des_info c record /file_info/ file pointer (p_file,file) c record /des_expanded/ des_expanded pointer (p_des_expanded,des_expanded) c p_file = control.top_file do while(p_file .ne. 0) p_des_expanded = file.top_des do while(p_des_expanded .ne. 0) c if(des_expanded.p_des_info .eq. %loc(des_info)) then if((control.debug .and. debug_expand) .ne. 0) then call dix_main_print_debug(control,debug_expand, 1 'Clearing expand flag for '// 1 des_expanded.handle(1:des_expanded.nk_handle)// 1 ' file '// 1 file.handle(1:des_expanded.nk_handle)) endif des_expanded.is_expanded = .false. endif p_des_expanded = des_expanded.link.forw end do p_file = file.link.forw end do return end subroutine dix_des_inv_des_file(control,file) implicit none c c The file data changed, set the expand flag for all c desciptions pointing to this file c include 'dix_def.inc' record /control/ control record /file_info/ file c record /des_expanded/ des_expanded pointer (p_des_expanded,des_expanded) c p_des_expanded = file.top_des do while(p_des_expanded .ne. 0) c if((control.debug .and. debug_expand) .ne. 0) then call dix_main_print_debug(control,debug_expand, 1 'Clearing expand flag for '// 1 des_expanded.handle(1:des_expanded.nk_handle)// 1 ' file '// 1 file.handle(1:des_expanded.nk_handle)) endif des_expanded.is_expanded = .false. p_des_expanded = des_expanded.link.forw end do return end