function dix_dump(control,iterm,dis) implicit none c c Duump the data, either c 1. screen mode c 2. file mode (either interactive or not) c include 'dix_def.inc' record /control/ control !:io: control structure integer*4 iterm !:o: the terminator function record /dis_pars/ dis !:i: display parameters integer*4 dix_dump !:f: function result c record /file_info/ file !:io: the file pointer (p_file,file) c integer*4 istat c integer*4 dix_dump_screen integer*4 dix_dump_interactive integer*4 dix_dump_file c if(control.mode .eq. mode_screen) then c c Screen mode c istat = dix_dump_screen (control,iterm,dis) elseif(control.mode .eq. mode_interactive) then c c Interactive mode c istat = dix_dump_interactive(control,iterm,dis,.false.) else c c File mode c p_file = control.top_file istat = dix_dump_file (control,file,iterm,dis) end if dix_dump = istat return end subroutine dix_dump_vars(control,dis,kpl,fldsiz,posasc) implicit none c c Compute raw_dump varables depending on screen width c include 'dix_def.inc' record /control/ control !:i: control strucutre record /dis_pars/ dis !:i: display parameters integer*4 kpl !:o: bytes /line integer*4 fldsiz !:o: field size integer*4 posasc !:o: the position of the ascii display c integer*4 kpl_long,kpl_byte integer*4 kpl_long_w,kpl_byte_w parameter (kpl_long =16,kpl_byte =8) parameter (kpl_long_w=32,kpl_byte_w=16) c c if(dis.hex) then fldsiz = dis.word*2+1 else if(dis.word .eq. 1) then fldsiz = 5 elseif(dis.word .eq. 2) then fldsiz = 6 else fldsiz = 11 end if end if if(control.ncols .eq. 132) then kpl = kpl_long_w if(dis.word .eq. 1 .or. (dis.word .eq. 2 .and. .not. dis.hex)) 1 kpl = kpl_byte_w else kpl = kpl_long if(dis.word .eq. 1 .and. .not. dis.hex) kpl = kpl_byte endif posasc = kpl/dis.word*fldsiz+2 return end subroutine dix_dump_raw_line(control,byte_offs,kpl, 1 nb_data,data_rec,dis,posasc, 1 begpos_bol,endpos_bol,n_bol,line, 1 ppos,fldsiz,file) implicit none c c Dump one line of raw data c include 'dix_def.inc' record /control/ control !:i: control structure integer*4 byte_offs !:i: byte offset integer*4 kpl !:i: byte/line displayed integer*4 nb_data !:i: number of bytes in dta byte data_rec(*) !:i: the data record /dis_pars/ dis !:i: display parameters integer*4 posasc !:i: pos of ascii display integer*4 begpos_bol(*) !:o: start of bold printing integer*4 endpos_bol(*) !:o: end of bold printing integer*4 n_bol !:o: nbold parts (part of current key) character*(*) line !:o: the line integer*4 ppos !:o: length of line integer*4 fldsiz !:i: size of field record /file_info/ file !:i: file info c character dix_util_kar_conv logical*4 dix_rms_offset_in_key c integer*4 ipos,l,nkar,m,max_len c include '($smgdef)' c character*(max_short_line_length) tline integer*4 data4 c byte datab(4) c integer*2 data2(2) c equivalence (datab,data2),(datab,data4) c record /des_rec/ des_rec c ipos = byte_offs c c setup record offset at end of record c n_bol = 0 line = ' ' ppos = 0 c c go through all bytes to do c if(.not. dis.hex) then c c Decimal dump c do l=kpl,1,-dis.word nkar = dis.word if(ipos+dis.word .gt. nb_data) nkar = nb_data-ipos data4 = 0 call dix_util_copy(nkar,data_rec(ipos+l-dis.word+1),data4) c if(ipos+l-dis.word .lt. nb_data) then c c Insert the integer format data c if(dis.unsigned) then des_rec.ent_type = enttyp_uint else des_rec.ent_type = enttyp_int endif des_rec.size = dis.word*8 des_rec.bit_offset = 0 des_rec.fld_adr = 0 des_rec.fld_len = 0 c call dix_con_intasc(nb_data,des_rec,data4,tline,nkar,.false., 1 max_len,.false.,control) line(ppos+1:ppos+fldsiz) = ' ' line(ppos+1+fldsiz-nkar:ppos+fldsiz) = tline(1:nkar) if(dix_rms_offset_in_key(file,ipos+l-dis.word,nkar)) then c c Is key field c m = 1 do while(line(ppos+m:ppos+m) .eq. ' ') m = m+1 end do n_bol = n_bol + 1 begpos_bol(n_bol) = ppos+m endpos_bol(n_bol) = ppos+fldsiz end if endif ppos = ppos + fldsiz end do else c c Hex mode c do l=kpl,1,-1 if((l .ne. kpl) .and. (mod(l,dis.word) .eq. 0)) ppos = ppos + 1 if(ipos+l .le. nb_data) then c c Insert hex (long)word format (per byte) c write(line(ppos+1:ppos+2),1010) data_rec(ipos+l) 1010 format(z2.2) if(dix_rms_offset_in_key(file,ipos+l-1,1)) then c c Is key field, so make highlight c if(n_bol .eq. 0 .or. endpos_bol(n_bol)+1 .ne. ppos+1) then n_bol = n_bol + 1 begpos_bol(n_bol) = ppos+1 end if endpos_bol(n_bol) = ppos+2 end if end if ppos = ppos + 2 end do end if c c now do the ascii data c ppos = posasc data4 = 0 do l=1,kpl c c set the ASCII data c if(ipos+l .le. nb_data) then call dix_util_copy(1,data_rec(ipos+l),data4) line(ppos+1:ppos+1) = dix_util_kar_conv(char(data4)) if(dix_rms_offset_in_key(file,ipos+l-1,1)) then if(n_bol .eq. 0 .or. endpos_bol(n_bol)+1 .ne. ppos+1) then n_bol = n_bol + 1 begpos_bol(n_bol) = ppos+1 end if endpos_bol(n_bol) = ppos+1 end if end if ppos = ppos + 1 end do c c insert offset if needed c if(dis.number) then c c Insert the offset c if(dis.number_hex) then ppos = ppos + 1 write(line(ppos+1:ppos+7),1000) ipos 1000 format(z7.7) ppos = ppos + 7 else ppos = ppos + 1 write(line(ppos+1:ppos+7),1001) ipos 1001 format(i7) ppos = ppos + 7 endif end if return end c function dix_dump_print_line(control,indent,line) implicit none c c Print line to file with indent c include 'dix_def.inc' record /control/ control !:io: control structure integer*4 indent !:i: indentation wanted character*(*) line !:i: the line to print logical*4 dix_dump_print_line c integer*4 bpos,epos logical first c external dix_msg_ctrlcseen logical dix_write_file c character*(max_line_length) indentasc c dix_dump_print_line = .false. if(control.control_c_seen) then call dix_message(control,dix_msg_ctrlcseen) goto 90 end if bpos = 1 first = .true. do while(first .or. (bpos .le. len(line))) epos = min(bpos+control.ncols-1-indent,len(line)) if(indent .gt. 0) indentasc(1:indent) = ' ' if(.not. dix_write_file(control, 1 indentasc(1:indent)//line(bpos:epos))) goto 90 bpos = epos+1 first = .false. end do dix_dump_print_line = .true. 90 return end subroutine dix_dump_print_par(control,n_par,pars,mask,hex) implicit none c c Print out parameters c include 'dix_def.inc' integer*4 n_par !:i: # parameters record /param/ pars(*) !:i: parameter data character*(*) mask !:i: print mask logical hex !:i: print in hex? record/control/ control !:io: control structure c integer*4 nk,k,nk1,l character*(max_line_length) line character*(max_short_line_length) temp c integer*4 dix_util_get_len logical*4 dix_dump_print_line logical dix_util_match_string_wild c do k=1,n_par nk = dix_util_get_len(pars(k).name) if(dix_util_match_string_wild(pars(k).name(1:nk),mask, 1 .false.,.false.)) then if(hex .or. pars(k).hex .eq. translate_hex) then call sys$fao('''!XL''X',nk1,temp,%val(pars(k).value)) elseif(pars(k).hex .eq. translate_oct) then call sys$fao('''!OL''O',nk1,temp,%val(pars(k).value)) elseif(pars(k).hex .eq. translate_bin) then temp = ' ' nk1 = 32 l = pars(k).value do while(l .ne. 0) temp(nk1:nk1) = '0' if(l) temp(nk1:nk1) = '1' l = ishft(l,-1) nk1 = nk1 - 1 end do if(nk1 .eq. 32) then temp(nk1:nk1) = '0' nk1 = nk1 - 1 endif temp = ''''//temp(nk1+1:32)//'''B' nk1 = 1 + 32-nk1 +1 + 2 else call sys$fao('!SL', nk1,temp,%val(pars(k).value)) endif call sys$fao('Parameter !AS = !AS',nk,line, 1 pars(k).name(1:nk),temp(1:nk1)) if(.not.dix_dump_print_line(control,0,line(1:nk))) goto 40 end if end do 40 return end subroutine dix_dump_print_line_int(control,ndes,des) implicit none c c Print out descriptions (in internal-expanded format) c include 'dix_def.inc' c record /control/ control !:io: control structure integer*4 ndes !:i: ndescriptions record /des_rec_fil/des(*) !:i: descriptions c character*(max_command_length) line integer*4 nk,k,siz,depth,descr(2),nk1 integer*4 dix_dump_print_line integer*4 dix_dump_print_line_br integer*4 dix_util_get_len c logical*4 field_mode c field_mode = .false. c depth = 1 do k=1,ndes call dix_util_get_type_name(des(k).ent_type,line,nk) if(des(k).ent_type .eq. enttyp_field ) field_mode = .true. if(des(k).ent_type .eq. enttyp_endfield) field_mode = .false. siz = des(k).size if(.not. field_mode) siz = siz/8 if(des(k).size_asc .gt. ' ') then nk1 = dix_util_get_len(des(k).size_asc) call sys$fao('*(!AS=!UL)',nk1,line(nk+1:), 1 des(k).size_asc(1:nk1),%val(siz)) nk = nk + nk1 elseif(des(k).size .gt. 0) then call sys$fao('*!UL',nk1,line(nk+1:),%val(siz)) nk = nk + nk1 endif if(des(k).translate .ne. translate_nor) then if(des(k).translate .eq. translate_hex) line(nk+1:) = '/HEX' if(des(k).translate .eq. translate_oct) line(nk+1:) = '/OCT' if(des(k).translate .eq. translate_bin) line(nk+1:) = '/BIN' nk = nk + 4 endif c if(des(k).case .ne. case_no_case) then if(des(k).case .eq. case_upper) line(nk+1:) = '/UPP' if(des(k).case .eq. case_lower) line(nk+1:) = '/LOW' nk = nk + 4 endif c nk = max(10,nk+2) nk = max(nk,20-depth) line(nk:) = des(k).name nk = nk + 1 + des(k).nam_len if(des(k).ent_type .ne. enttyp_map) 1 call insert_dims(line,des(k).rep,nk) c if(des(k).ent_type .eq. enttyp_endstructure .or. 1 des(k).ent_type .eq. enttyp_endunion .or. 1 des(k).ent_type .eq. enttyp_endfield .or. 1 des(k).ent_type .eq. enttyp_endrange .or. 1 des(k).ent_type .eq. enttyp_endmap) depth = depth - 2 c if(.not.dix_dump_print_line(control,depth,line(1:nk))) goto 40 if(des(k).fld_len .gt. 0) then descr(1) = des(k).fld_len descr(2) = des(k).fld_adr if(.not.dix_dump_print_line_br(control,depth+4,descr)) goto 40 endif c if(des(k).ent_type .eq. enttyp_structure .or. 1 des(k).ent_type .eq. enttyp_union .or. 1 des(k).ent_type .eq. enttyp_field .or. 1 des(k).ent_type .eq. enttyp_range .or. 1 des(k).ent_type .eq. enttyp_map) depth = depth + 2 end do c 40 return end function dix_dump_print_line_br(control,indent_in,line) implicit none c c Print out line in brackets c include 'dix_def.inc' record /control/ control !:io: cotnrol strucutre integer*4 indent_in !:i: indent wanted character*(*) line !:i: the line logical*4 dix_dump_print_line_br c logical*4 dix_dump_print_line dix_dump_print_line_br = dix_dump_print_line(control,indent_in, 1 '['//line//']') return end subroutine insert_dims(line,rep,nk) implicit none c c Insert dimensions afte a name c include 'dix_def.inc' character*(*) line !:io: the line record /repeat/ rep !:i: the repeat structure (max 3 dimensions) integer*4 nk !:io: length of line c integer*4 dix_util_get_len c logical*4 hebwat,hebiets integer*4 k,nk1,bpos c hebwat = .false. bpos = nk+1 line(bpos:bpos) = '(' bpos = bpos+1 do k=1,max_dimension hebiets = .false. if(rep.dim(k).low_name .ne. ' ') then nk1 = dix_util_get_len(rep.dim(k).low_name) call sys$fao('!AS=!UL:',nk1,line(bpos:), 1 rep.dim(k).low_name(1:nk1), 2 %val(rep.dim(k).low)) bpos = bpos + nk1 hebiets = .true. elseif(rep.dim(k).low .ne. rep.dim(k).high) then if(rep.dim(k).low .ne. 1) then call sys$fao('!UL:',nk1,line(bpos:),%val(rep.dim(k).low)) bpos = bpos + nk1 hebiets = .true. endif endif if(rep.dim(k).high_name .ne. ' ') then nk1 = dix_util_get_len(rep.dim(k).high_name) call sys$fao('!AS=!UL',nk1,line(bpos:), 1 rep.dim(k).high_name(1:nk1), 1 %val(rep.dim(k).high)) bpos = bpos + nk1 hebiets = .true. elseif(rep.dim(k).high .ne. 1) then call sys$fao('!UL',nk1,line(bpos:),%val(rep.dim(k).high)) bpos = bpos + nk1 hebiets = .true. endif if(hebiets) then hebwat = .true. line(bpos:bpos) = ',' bpos=bpos + 1 endif end do bpos=bpos - 1 line(bpos:bpos) = ')' if(.not. hebwat) then line(nk+1:) = ' ' else nk = bpos end if return end subroutine dix_dump_copy(file) implicit none c include 'dix_def.inc' record /file_info/ file c file.data.nb_sav = file.data.nb_data call lib$movc3(file.data.nb_data,file.data.data_rec,file.data.data_sav) call lib$movc3(file.data.nb_vfc, file.data.vfc_data, 1 file.data.vfc_data_sav) file.got_record = .true. file.rewound = .false. return end c function dix_dump_record_changed(data) implicit none c c Return true if record changed c include 'dix_def.inc' record /data_info/ data logical dix_dump_record_changed c integer*4 k c c Assume changed c dix_dump_record_changed = .true. c c Check length first c if(data.nb_sav .ne. data.nb_data) goto 90 c c Now the normal buffer data c do k=1,data.nb_data if(data.data_rec(k) .ne. data.data_sav(k)) goto 90 end do c c And the vfc_data (if there) c do k=1,data.nb_vfc if(data.vfc_data(k) .ne. data.vfc_data_sav(k)) goto 90 end do c dix_dump_record_changed = .false. 90 return end function dix_dump_set_link(control,i_des,des_recs,err_arg, 1 file,log_it,link_rec, 1 value,link_fnam) implicit none c include 'dix_def.inc' record /control/ control !:io: the control structure integer*4 i_des !:i: the description line wanted record /des_rec/ des_recs(*) !:i: the desciptions character*(*) err_arg !:o: error argument record /file_info/ file !:i: the file logical log_it !:i: do you want to log it record /link_rec/ link_rec !:o: the link record record /value/ value !:o: the value for key/record number character*(*) link_fnam !:o: return link filename logical dix_dump_set_link !:f: the function result c integer*4 istat,nk c external dix_msg_nolink external dix_msg_notchar external dix_msg_folrec external dix_msg_folkey external dix_msg_notlog external dix_msg_ifnottrue integer*4 dix_eval_expression c logical is_symb,is_defined c character*(max_line_length) expression,fieldname c record /link_rec/ wlink_rec pointer (p_wlink_rec,wlink_rec) c is_defined = .false. if(des_recs(i_des).p_link_rec .eq. 0) then istat = %loc(dix_msg_nolink) err_arg = ' ' call lib$movc3(des_recs(i_des).nam_len, 1 %val(des_recs(i_des).nam_adr), 1 %ref(err_arg)) else p_wlink_rec = des_recs(i_des).p_link_rec link_rec = wlink_rec c c Define a symbol with the name $FIELD c nk = des_recs(i_des).nam_len call lib$movc3(nk,%val(des_recs(i_des).nam_adr),%ref(fieldname)) c c store the value of the field to the symbol $FIELD c call dix_eval_cvt(control,des_recs(i_des),file,value) call dix_symbol_add(control,'$FIELD',value,err_arg) is_defined = .true. c c Evaluate the filename c nk = link_rec.nk_link_file link_fnam = link_rec.link_file(1:nk) c if(nk .gt. 0) then call dix_dump_substitute(link_fnam,nk, 1 fieldname(1:des_recs(i_des).nam_len)) c istat = dix_eval_expression(control,link_fnam(1:nk), 1 value,.false.,err_arg,.false.,is_symb) if(.not. istat) goto 90 c c Result must be character c if(value.type .ne. symb_typ_char) then istat = %loc(dix_msg_notchar) goto 90 endif c link_fnam = ' ' call dix_eval_copy_char_fix(value.strdes,link_fnam,nk) endif c c First check if the IF expression is valid c if(link_rec.nk_if .gt. 0) then c c Evaluatie the (IF-)expression c expression = link_rec.IF_line nk = link_rec.nk_if call dix_dump_substitute(expression,nk, 1 fieldname(1:des_recs(i_des).nam_len)) istat = dix_eval_expression(control,expression(1:nk), 1 value,.false.,err_arg,.false.,is_symb) if(.not. istat) goto 90 if(value.type .ne. symb_typ_log) then istat = %loc(dix_msg_notlog) err_arg = expression(1:nk) goto 90 endif if(.not. value.lval) then err_arg = expression(1:nk) istat = %loc(dix_msg_ifnottrue) goto 90 endif endif c c Check if compute field c if(link_rec.nk_compute .eq. 0) then c c No, so take the contents of the field c call dix_eval_cvt(control,des_recs(i_des),file,value) istat = 1 else c c Evaluate c expression = link_rec.comp_line nk = link_rec.nk_compute c c Now substitute 'thisfield' by the name of the field c call dix_dump_substitute(expression,nk, 1 fieldname(1:des_recs(i_des).nam_len)) istat = dix_eval_expression(control,expression(1:nk), 1 value,.false.,err_arg,.false.,is_symb) endif if(istat) then if(log_it) then call dix_con_value_intasc(control,value,expression,nk,.false.) if(link_rec.key_nr .lt. 0) then c c Follow link record c call dix_message(control,dix_msg_folrec, 1 link_rec.link_file(1:link_rec.nk_link_file), 1 expression(1:nk)) else c c Following link key c call dix_message(control,dix_msg_folkey, 1 link_rec.link_file(1:link_rec.nk_link_file), 1 expression(1:nk),%val(link_rec.key_nr)) endif endif endif endif 90 if(is_defined) then call dix_symbol_delete(control,'$FIELD',.false.,.true.,.false.) endif dix_dump_set_link = istat return end subroutine dix_dump_substitute(expression,nk,fieldname) implicit none c c Replace 'this_field' with the name of the field c character*(*) expression integer*4 nk character*(*) fieldname c character*(*) thisfield parameter (thisfield='''THISFIELD''') c integer*4 ipos c 20 ipos = index(expression(1:nk),thisfield) if(ipos .ne. 0) then expression = expression(1:ipos-1)// 1 fieldname//expression(ipos+len(thisfield):nk) nk = nk - len(thisfield) + len(fieldname) goto 20 endif return end function dix_dump_check_deposit(control,file,des_rec, 1 ascdat,dis,repaint,is_getfields) implicit none c c We have a new value in the ascdat c Return false if convert is not oke c include 'dix_def.inc' record /control/ control !:io: control structure record /file_info/ file !:io: the file+data record /des_rec/ des_rec !:i: the current des_rec character*(*) ascdat !:i: the (modified) data record /dis_pars/ dis !:i: display mode wanted logical repaint !:o: signal record repaint logical is_getfields !:i: was key getfields? integer*4 dix_dump_check_deposit c record /data_info/ temp_data integer*4 nbits_f,k integer*4 pos1,siz1,pos2,siz2 logical larger,is_rec_size c record /des_expanded/ des_expanded pointer (p_des_expanded,des_expanded) c record /des_rec/ des_rec_w c logical dix_con_ascint logical dix_main_question logical dix_util_overlap external dix_msg_reclchg external dix_msg_rectrunc external dix_msg_cannotchg c character*(max_line_length) field_name c c Assume convert of text went wrong, and repaint is not needed c dix_dump_check_deposit = .false. repaint = .false. if(is_getfields) goto 10 c c If des_rec points to the recordsize the bit_offset is <0 c (.nb_data is before .data_rec) c is_rec_size = des_rec.bit_offset .le. 0 c c First copy the record data to a temp buffer c temp_data = file.data c c Try to convert, this can modify temp_data c if(dix_con_ascint(ascdat,temp_data.data_rec,des_rec, 1 dis.hex,nbits_f,control)) then c c Conversion success c if(is_rec_size) then c c Nothing changed c if(file.data.nb_data .eq. temp_data.nb_data) goto 88 endif c c Check for room for data (cannot change for BITFIELD fields) c if((nbits_f .ne. des_rec.size) .or. is_rec_size) then c c Size changed, check if var type record c if(.not. ((file.indexed .or. file.relative) .and. .not. 1 file.fixed)) then if(is_rec_size) then call dix_message(control,dix_msg_cannotchg) goto 90 endif if(.not. dix_main_question(control, 1 'Cannot change record length, continue', 1 .true.)) goto 90 end if c c Make room , but only if des_rec points to the record and not the c record_length c pos1 = des_rec.bit_offset/8 if(.not. is_rec_size) then pos2 = des_rec.size/8 larger = nbits_f .gt. des_rec.size if(nbits_f .lt. des_rec.size) then call dix_util_copy(file.data.nb_data-pos1-des_rec.size/8, 1 file.data.data_rec(pos1+1+des_rec.size/8), 1 file.data.data_rec(pos1+1+nbits_f/8)) elseif(nbits_f .gt. des_rec.size) then do k=1,file.data.nb_data-pos1-des_rec.size/8 file.data.data_rec(file.data.nb_data-k+1+ 1 nbits_f/8-des_rec.size/8) = 1 file.data.data_rec(file.data.nb_data-k+1) end do end if endif c c Check if record length can be changed c if((file.indexed .or. file.relative) .and. .not. 1 file.fixed) then if(is_rec_size) then larger = file.data.nb_data .gt. temp_data.nb_data file.data.nb_data = temp_data.nb_data else file.data.nb_data = file.data.nb_data-des_rec.size/8+nbits_f/8 file.data.nb_data = max(file.minrecl,file.data.nb_data) endif if(file.maxrecl .ne. 0) then file.data.nb_data = min(file.maxrecl,file.data.nb_data) end if if(larger) then call dix_message(control,dix_msg_reclchg, 1 %val(file.data.nb_Data)) else call dix_message(control,dix_msg_rectrunc, 1 %val(file.data.nb_Data)) endif end if !recl changed repaint = .true. end if !field size changed c c Copy data in c call dix_util_move_bits(nbits_f, 1 temp_data.data_rec,des_rec.bit_offset, 1 file.data.data_rec,des_rec.bit_offset, 1 nbits_f,.false.) c else c c Convert went wrong c goto 90 endif c c Because of map (data overlying other data), we must check if something c changed for other fields, and if so do repaint the line c c If someone is dependend on this value, signal a repaint c and do the repaint c c Get the pos/size of the (changed) data c 10 pos1 = des_rec.bit_offset siz1 = des_rec.size p_des_expanded = file.cur_des c if(des_rec.dependency) repaint = .true. if(repaint) goto 80 c do k=1,des_expanded.n_des call dix_des_get_des(des_expanded,k,des_rec_w,field_name) pos2 = des_rec_w.bit_offset siz2 = des_rec_w.size if(dix_util_overlap(pos1,siz1,pos2,siz2)) then if(des_rec_w.dependency) then repaint = .true. goto 80 endif end if end do c c Now go through all descriptions and reexpand them all c 80 call dix_des_expand_all(control,file) c 88 dix_dump_check_deposit = .true. 90 return end