options /recursi function dix_dump_interactive(control,iterm,dis,from_usertype) implicit none c c Display/modify data interactively c include 'dix_interactive.inc' record /control/ control !:io: the control structure integer*4 iterm !:o: the teminator (action wanted) record /dis_pars/ dis !:i: the display parameters logical from_usertype !:i: from usertype? integer*4 dix_dump_interactive !f: function result c# c Common for control_c c logical seen_signal common /ignore_message_common/ seen_signal c c Include files c include '($dcdef)' include '($stsdef)' c include '($smgdef)' c c Records c record /file_level/ file_level pointer (p_file_level,file_level) record /des_expanded/ des_expanded pointer (p_des_expanded, des_expanded) record /des_info/ des_info pointer(p_des_info,des_info) record /struct_level/ struct_level pointer (p_struct_level,struct_level) record /des_rec/ des_recs(1) pointer (p_des_recs,des_recs) record /struct_pointers/ ptrs record /value/ val,val1 record /dis_pars/ dis_work record /file_level/ save_level record /file_info/ file pointer (p_file,file) record /file_info/ temp_file pointer (p_temp_file,temp_file) record /link_rec/ link_rec c c Local Variables c character*(max_line_length) fieldname,tline character*(max_symbol_name_length) if_state,set_state,context character*(max_str_len) ascdat,totline,arguments,ototline character*(max_symbol_name_length) symbol,symbol1 character kar integer*4 nk_tot,begval,endval,incval,workval,nk_if,onk_tot integer*4 nk,k,ipos,offs,line_ptr,save_lun,nk_arg,ptr_desc integer*4 istat,l,nl,line_level,nlevel,save_paged integer*4 nk_field,nk_t,save_ncols integer*4 where,symbtyp logical*4 skip,is_call,was_call,trans,do_descr !,changed, logical*4 on_command,all,full,is_symbol character*(max_verb_length) verb c record /gosub_entry/ gosub_entries(*),gosub_entry pointer (p_gosub_entries,gosub_entries) c real*4 real4_work c integer*4 nk_label character*(max_label_length) label character*(max_short_line_length) modflag,temp logical*4 then_mode,auto,do_close,do_append integer*4 nk_line,key,nk_symb,nk_symb1,descr(2),flag,start_level,lun1 logical signal,logit,from_read,overflow character*(max_line_length) line character*(max_err_arg_length) err_arg character*(max_filename_length) link_fnam character*(max_str_len) eval_line integer*4 err_status logical do_sys,do_usr,do_fil,do_it logical jump_from_control logical jump_from_call,jump_from_at logical jump_from_end_statement c integer*4 max_rfas,n_rfas parameter (max_rfas=2) record /rfa/ rfas(max_rfas) c c Functions c integer*4 dix_inter_open_level integer*4 dix_symbol_add_str integer*4 dix_symbol_add integer*4 dix_symbol_set_alias integer*4 dix_symbol_find integer*4 smg$delete_key_def integer*4 dix_inter_parse_for integer*4 dix_inter_set_file integer*4 dix_symbol_get_symbol integer*4 dix_main_follow integer*4 dix_main_follow_back integer*4 memtab_read integer*4 dix_dump_i_wrfile integer*4 dix_dump_inter_next_descr integer*4 dix_search_search_file integer*4 dix_search_set_flags integer*4 dix_dump_int_show_rel integer*4 dix_dump_get_rfa integer*4 dix_dump_file integer*4 lib$set_symbol integer*4 lib$get_symbol c integer*4 sys$setprn c logical*4 dix_dump_i_dcl_parse_table logical*4 dix_con_i4 logical*4 cli$present external lib$get_input integer*4 dix_startup_set_real integer*4 dix_startup_set_integer integer*4 dix_startup_check_symbol c integer*4 dix_dump_i_open_output logical*4 dix_eval_expression logical*4 dix_eval_expression1 logical*4 cli$get_value logical dix_rms_check_rfa logical dix_des_get_all integer dix_rms_rewind integer dix_inter_read_line integer dix_inter_unsymbol_verb logical dix_symbol_delete integer*4 dix_rms_delete logical dix_dump_set_link integer*4 dix_dump_i_exam integer*4 dix_dump_i_depo integer*4 dix_inter_get_params integer*4 dix_inter_set_local integer*4 dix_dump_inter_sel_file integer*4 smg$define_key integer*4 dix_dump_inter_get_file integer*4 dix_main_get_rec_int integer*4 dix_main_rfa_restore c integer*4 dix_dump_i_get_keys integer*4 dix_main_get_keyvals integer*4 dix_dump_i_sel_des c integer*4 dix_des_expand integer*4 dix_util_find_char_bracket integer*4 dix_edit_des integer*4 dix_util_check_name integer*4 dix_dump_i_show_des integer*4 dix_dump_i_show_des_exp integer*4 dix_inter_find_label integer*4 dix_inter_create_new_level integer*4 dix_main_get_files integer*4 dix_rms_get integer*4 dix_rms_update logical*4 dix_util_str_eq integer*4 dix_rms_read_prev_rec_idx integer*4 dix_rms_read_prev_rec_rel c c Messages c external dix_msg_ambig external dix_msg_aroverfl external dix_msg_cannotchg external dix_msg_chgdrecl external dix_msg_closbnotf external dix_msg_cmpasnum external dix_msg_datasav external dix_msg_datarest external dix_msg_desadd external dix_msg_desnotm external dix_msg_desrem external dix_msg_enotint external dix_msg_entryign external dix_msg_errgetl external dix_msg_fieldnotf external dix_msg_filnotop external dix_msg_general external dix_msg_ignoterm external dix_msg_illcomm external dix_msg_illcycle external dix_msg_illends external dix_msg_illends1 external dix_msg_illret external dix_msg_illkey external dix_msg_illleave external dix_msg_illoffs external dix_msg_illdigits external dix_msg_illwidth external dix_msg_invlog external dix_msg_labnotf external dix_msg_mrknotmrk external dix_msg_nocall external dix_msg_nodescr external dix_msg_nofilopen external dix_msg_noupdate external dix_msg_nomordes external dix_msg_norest external dix_msg_noscreen external dix_msg_noseastr external dix_msg_notaddes external dix_msg_notchar external dix_msg_notlog external dix_msg_notindex external dix_msg_notinmod external dix_msg_notonterm external dix_msg_opernotf external dix_msg_openbnotf external dix_msg_pagemode external dix_msg_setedt external dix_msg_stricmode external dix_msg_symbform external dix_msg_usingfil external dix_msg_usingdes external dix_msg_unexpchar external dix_msg_wrargtyp external dix_msg_widthset c c There is a problem with dcl_parse c if the first statement has a problem, the the get_value('$line') c ends in an access violation c to prevent this we do a dcl_parse here c start_level = control.depth c p_file_level = control.cur_level !point to the correct level call sys$fao('SHOW PAG',nk,line) call dix_dump_i_dcl_parse_table(file_level,line,nk,.true.) c c INit local vars, since they have variable string type c call dix_eval_init_value(val) call dix_eval_init_value(val1) err_status = 1 c c Init some vars c on_command = .false. jump_from_end_statement = .false. jump_from_control = .false. jump_from_call = .false. jump_from_at = .false. from_read = .true. dis.tag = .false. !do not display tags c c Main loop for this module c 10 p_file = control.cur_file c c Set the control block for the current command level c p_file_level = control.cur_level !point to the correct level p_struct_level = file_level.cur_struct !can be 0 c c Check for the current file c if(.not. from_usertype) then if(%loc(file) .ne. 0) then c c We have a file current c nk = file.nk_fnam line = file.fnam(1:nk) if(%loc(file) .ne. control.old_filep) then if(file.modify) then modflag = '/MOD' else modflag = '/NOMOD' endif call dix_message(control,dix_msg_usingfil,line(1:nk), 1 modflag(1:6)) control.old_desp = -1 !so this will be signalled too end if if(file.cur_des .eq. 0) file.cur_des = file.top_des else c c We have no file current c nk = 0 if(control.old_filep .ne. 0) then call dix_message(control,dix_msg_nofilopen) endif endif c if(control.old_filep .ne. %loc(file)) then call dix_symbol_add_str(control,'$FILE',line(1:nk),err_arg) control.old_filep = %loc(file) endif endif c c Check for the current description record c Reentry after descriptor changed c if(p_file .ne. 0) then p_des_expanded = file.cur_des else p_des_expanded = 0 endif p_des_info = 0 if(p_des_expanded .ne. 0) p_des_info = des_expanded.p_des_info c if(.not. from_usertype) then c c Restart for new record, reexpand the description (if des present) c if(p_des_expanded .ne. 0) then c c Now we have description, try to expand it c if(.not. des_expanded.is_expanded) then if(.not. dix_des_expand(control,des_expanded, 1 file,.false.)) then c c description failed, now tell the user we are sorry, but no description c call dix_message(control,dix_msg_nodescr) end if endif end if c if(p_des_info .ne. control.old_desp) then if(p_des_info .eq. 0) then nk = 0 else call dix_des_display(control,des_info,line,nk,.false.) call dix_message(control,dix_msg_usingdes,line(1:nk)) endif call dix_symbol_add_str(control,'$DESCRIPTION',line(1:nk),err_arg) control.old_desp = p_des_info endif endif c c All description things done c c Main loop for program c return here with err_status (and err_arg) set to c values representing the status of the last command c dix_inter_signal will signal warning/error/fatal c and when the error level execeeds the current ON-setting c return with an exit c call dix_inter_signal(control,err_status,err_arg, 1 totline,nk_tot,on_command, 1 file_level,from_read) if(nk_tot .ne. 0) then c c err_status was a serious error (looking at the ON level) c We have an error statement from the on xxxxx commands c close all command files until we have a terminal as input c from_read = .false. else c c Read next command line c from_read = .true. err_status = dix_inter_read_line(control,totline,nk_tot, 1 .false.,ptrs,line_level,err_arg) if(.not. err_status) then c c Error during read, if in label search signal error c else return exit c if(err_status .ne. 0) goto 10 c c End of file, just exit c totline = 'EXIT' nk_tot = 4 end if err_status = 1 c c See if symbol assignment c ipos = index(totline(1:nk_tot),'=') if(ipos .ne. 0) then c c See if symbol assignment c err_status = dix_startup_check_symbol(control,totline,nk_tot, 1 err_arg,is_symbol) if(err_status) goto 10 !all oke if(is_symbol) goto 10 !it was a symbol assignment error endif c c Now unsymbol the verb c err_status = dix_inter_unsymbol_verb(control,totline,nk_tot,err_arg) if(.not. err_status) goto 10 c c Make line decent, but keep original c decent_line upcases, and this in not desired for deposit c onk_tot = nk_tot ototline = totline call dix_util_decent_line(nk_tot,totline) c c Massage line (line end if => endif, @=>AT etc) c call dix_inter_massage(totline,nk_tot) if(nk_tot .eq. 0) goto 10 on_command = .false. endif c c Go parse the command line c if a command does not parse oke c c Do not let cli$dcl_parse signal errors, we handle them later c so establish a return handler. The common seen_signal will c be set if this routine is entered c 25 seen_signal = .false. err_Status = dix_dump_i_dcl_parse_table(file_level, 1 totline,nk_tot,.true.) c c Save the DIXRFA pointer for the current record c if(%loc(file) .ne. 0) call dix_rms_save_rfa_std(file) c c Clear the /error and /end= label names c control.error_label = ' ' control.eof_label = ' ' c if(.not. err_status) then c c Otherwise error, let DCL signal the message (no lib$establish) c (at least if dcl_parse signals it) c if(seen_signal) then c c There was an error seen in the ignore_message handler c dcl_parse will output the full message c call dix_dump_i_dcl_parse_table(file_level,totline,nk_tot,.false.) err_status = err_status .or. sts$m_inhib_msg endif goto 10 endif c c All dcl_parsing oke, now process the verb c call cli$get_value('$VERB',verb) c control.linenr = 0 !no output line(s) yet iterm = 0 !not yet return to main routine c c if we came from CALL, and verb <> SUBR, this is an invalid call c if(jump_from_call .and. verb .ne. 'SUBR') then err_status = %loc(dix_msg_nocall) jump_from_call = .false. goto 10 endif c c Is the previous command is a AT (@), check if this (the first) c line is an ENTRY c if(jump_from_at) then jump_from_at = .false. is_call = verb .eq. 'ENTR' err_status = dix_inter_get_params(control,arguments(1:nk_arg), 1 err_arg,is_call) if(.not. err_status) goto 10 if(is_Call) goto 10 endif c c Now start executing verbs c if(verb .eq. 'AT') then c c @ command c syntax @name/out=file param[,param...] c nk_tot = 0 call cli$get_value('p1',totline,nk_tot) !name of the routine nk_t = 0 call cli$get_value('output',tline,nk_t) !output file nk_arg = 0 call cli$get_value('p2',arguments,nk_arg) !parameters c c Check if arguments are valid c ascdat = arguments(1:nk_arg) nk = nk_arg do while(nk .gt. 0) err_status = dix_eval_expression1(control,ascdat(1:nk),val, 1 .false.,err_arg,.false.,kar,ipos,is_symbol) if(.not. err_status) then nk = 0 else nk = nk - ipos + 1 ascdat = ascdat(ipos:) endif enddo if(err_status) then c c Args are oke, now open the file c err_status = dix_inter_open_level(control,totline(1:nk_tot), 1 tline(1:nk_t)) if(.not. err_status) then c c Could not open level, so signal c err_arg = totline(1:nk_tot) else c c Open level is ok, fill in the new file_level control block c p_file_level = control.cur_level p_struct_level = file_level.cur_struct !is 0 file_level.is_call = .false. file_level.return_line = 0 jump_from_at = .true. !remember we came from AT endif endif c elseif(verb .eq. 'ENTR') then c c Entry command c syntax c entry param[/qual]0,param[/qual]...] c is already handeled above c if(file_level.is_term) goto 73 !not on terminal err_status = %loc(dix_msg_entryign) c elseif(verb .eq. 'DEFI') then c c Define c syntax: c define/key keyname string [/qualifiers] for inter mode c define/key screenkey dix_function [/qualifiers] for screen mode c if(cli$present('key')) then err_status = smg$define_key(control.keytable_id,totline(1:nk_tot)) elseif(cli$present('skey')) then call cli$get_value('p1',line) call cli$get_value('set_state',set_state) call cli$get_value('context_screen',context) if(set_state .eq. ' ') then call cli$get_value('p2',tline) else tline = ' ' endif call cli$get_value('if_state',if_state) c c Context is not yet used, but for future reference c call keydefs_add_key(control,line,if_state,set_state, 1 tline,context) else goto 70 endif c elseif(verb .eq. 'REAL' .or. 1 verb .eq. 'INTE' .or. 1 verb .eq. 'DATE' .or. 1 verb .eq. 'LOGI' .or. 1 verb .eq. 'DECI' .or. 1 verb .eq. 'CHAR') then c c Declaration statements c syntax c type : name[=value] c if(verb .eq. 'REAL') symbtyp = symb_typ_real if(verb .eq. 'INTE') symbtyp = symb_typ_int if(verb .eq. 'DATE') symbtyp = symb_typ_date if(verb .eq. 'DECI') symbtyp = symb_typ_decimal if(verb .eq. 'LOGI') symbtyp = symb_typ_log if(verb .eq. 'CHAR') symbtyp = symb_typ_char nk = 0 call cli$get_value('p1',ascdat,nk) c c DO not do this in loops, unless it is the first time c k = 1 if(file_level.struct_level .ne. 0) then if(.not. struct_level.first) k = 0 endif c if(k .eq. 1) then err_status = dix_inter_set_local(control,ascdat,nk, 1 err_arg,symbtyp) else err_status = 1 endif c elseif(verb .eq. 'ALIA') then c c Define an alias symbol (not normally used command) c syntax : alias=symbol c err_status = dix_symbol_get_symbol('p1',symbol,nk_symb) !alias name if(err_status) then err_status = dix_symbol_get_symbol('p2',symbol1,nk_symb1) !alias name if(err_status) then err_status = dix_symbol_set_alias(control,symbol(1:nk_symb), 1 symbol1(1:nk_symb1),err_arg) else err_arg = symbol(1:nk_symb) endif else err_arg = symbol(1:nk_symb) endif c elseif(verb .eq. 'CYCL') then c c Cycle command, in a loop : goto the endloop, but stay in the loop c if(file_level.is_term) goto 73 if(file_level.struct_level .eq. 0) then c c Not is a loop c err_status = %loc(dix_msg_illcycle) else c c In a loop ,goto the end_label c call memtab_set_line_ptr(file_level.lun,struct_level.ptrs.end_ptr) endif c elseif(verb .eq. 'LEAV') then c c Leave command, leave the current loop c Syntax : LEAVE c if(file_level.is_term) goto 73 if(file_level.struct_level .eq. 0) then err_status = %loc(dix_msg_illleave) else call memtab_set_line_ptr(file_level.lun, 1 struct_level.ptrs.end_ptr) jump_from_control = .true. endif c elseif(verb .eq. 'WAIT') then c c Wait c Syntax : WAIT seconds c Wait seconds (integer or real) c nk = 0 call cli$get_value('p1',ascdat,nk) err_status= dix_eval_expression(control,ascdat(1:nk),val, 1 .false.,err_arg,.false.,is_symbol) if(err_status) then if(val.type .eq. symb_typ_int) then call lib$wait(1.0*val.ival) elseif(val.type .eq. symb_typ_real) then c c Make sure the real is *4 c call dix_con_cvt_float_real_f(control,val.rval, 1 real4_work,overflow) if(overflow) then err_arg = 'WAIT' err_status = %loc(dix_msg_aroverfl) else call lib$wait(1.0*real4_work) endif else err_status = %loc(dix_msg_wrargtyp) err_arg = 'WAIT' endif endif c elseif(verb .eq. 'SUBR') then c c Subroutine c syntax : LABEL : SUBROUTINE [parameters] c if(file_level.is_term) goto 73 c c If we did come from a call, get params and continue c if not skip unitl the ends(ub) c if(jump_from_call) then jump_from_call = .false. err_status = dix_inter_get_params(control,arguments(1:nk_arg), 1 err_arg,.true.) if(.not. err_status) then call dix_inter_close_level(control,.true.) p_file_level = control.cur_level p_struct_level = file_level.cur_struct endif else c c Goto the endsubroutine line c jump_from_control = .true. call memtab_set_line_ptr(file_level.lun,ptrs.end_ptr) endif c elseif(verb .eq. 'ENDS') then c c ENDSUBROUTINE c syntax : ENDSUBROUTINE c if(file_level.is_term) goto 73 if(jump_from_control) then jump_from_control = .false. else line_ptr = file_level.return_line call dix_inter_close_level(control,.true.) p_file_level = control.cur_level p_struct_level = file_level.cur_struct call memtab_set_line_ptr(file_level.lun,line_ptr) endif c elseif(verb .eq. 'CALL') then c c CALL c Syntax : CALL LABEL C Call of a subroutine c if(file_level.is_term) goto 73 call memtab_get_line_ptr(file_level.lun,line_ptr) nk_label = 0 call cli$get_value('p1',label,nk_label) nk_arg = 0 call cli$get_value('p2',arguments,nk_arg) c c Check if the arguments are valid c ascdat = arguments(1:nk_arg) nk = nk_arg do while(nk .gt. 0) err_status = dix_eval_expression1(control,ascdat(1:nk),val, 1 .false.,err_arg,.false.,kar,ipos,is_symbol) if(.not. err_status) then nk = 0 else nk = nk - ipos + 1 ascdat = ascdat(ipos:) endif enddo c if(err_status) then err_status = dix_inter_find_label(label, 1 line_level,err_arg,nlevel,file_level, 1 control) endif if(err_status) then err_status = dix_inter_create_new_level(control) if(err_status) then save_level = file_level p_file_level = control.cur_level p_struct_level = file_level.cur_struct file_level.verify = save_level.verify !set verify file_level.lun_out = save_level.lun_out !and lun_out call dix_inter_set_default_error(file_level) file_level.nk_file = save_level.nk_file file_level.filename = save_level.filename file_level.lun = save_level.lun file_level.is_term = save_level.is_term file_level.output_opened = .false. !so do not close file_level.is_call = .true. !tis a call not a @ file_level.return_line = line_ptr !return address file_level.strict_mode = save_level.strict_mode jump_from_call = .true. endif !could not create new level endif !could not find label c elseif(verb .eq. 'DECL') then c c DECLARE c Syntax : DECLARE[/qualifier] symbol[/qualifier][,symbol[/qualifier...]] c nk = 0 call cli$get_value('p1',ascdat,nk) symbtyp = symb_typ_none c c FIrst get global type c if(cli$present('REAL' )) symbtyp = symb_typ_real if(cli$present('INTEGER' )) symbtyp = symb_typ_int if(cli$present('DATE' )) symbtyp = symb_typ_date if(cli$present('DECIMAL' )) symbtyp = symb_typ_decimal if(cli$present('LOGICAL' )) symbtyp = symb_typ_log if(cli$present('CHARACTER')) symbtyp = symb_typ_char c c Declare must only be done once in a loop c k = 1 if(file_level.struct_level .ne. 0) then if(.not. struct_level.first) k = 0 endif c c Now parse each symbol (with its type) c if(k .eq. 1) then err_status = dix_inter_set_local(control,ascdat,nk, 1 err_arg,symbtyp) else c c Subsequent times do not redefine it. c err_status =1 endif c elseif(verb .eq. 'NOOP') then c c Noop c syntax : NOOP c Do nothing c elseif(verb .eq. 'OPEN') then call dix_dump_get_err_lab(control,file_level) if(cli$present('p2')) then temp = 'p2' err_status=dix_symbol_get_symbol('p1',symbol,nk_symb) else temp = 'p1' nk_symb = 0 endif if(err_status) then logit = cli$present('log') err_status = dix_main_get_files(control,temp(1:2), 1 ' ',symbol(1:nk_symb),logit,.true.) c c If all oke, and we had no file open, and we have files now c jump to the first c if(err_status) then if(%loc(file) .eq. 0) then if(control.n_file .gt. 0) then control.cur_file = control.top_file endif endif endif else err_arg = symbol(1:nk_symb) endif elseif(verb .eq. 'EXIT') then c c Exit c syntax : exit [status] c call util_cli_get_number('p1',1,err_status) c c CLose one level, if c was_call = file_level.is_call line_ptr = file_level.return_line c do_close = .true. if(from_usertype) then if(control.depth .eq. start_level) do_close = .false. endif if(do_close) then call dix_inter_close_level(control,.true.) p_file_level = control.cur_level if(control.depth .lt. start_level) then iterm = key_exit else c c The strict mode is kept at file level. c the symbol routines make use of control.strict_mode, c so we need to keep them in sync c control.strict_mode = file_level.strict_mode p_struct_level = file_level.cur_struct if(was_call) call memtab_set_line_ptr(file_level.lun,line_ptr) endif else iterm = key_exit endif elseif(verb .eq. 'WHIL') then c c While c Syntax : WHILE Log-Expression c OPening statement of the WHILE/ENDWHILE construct c if(file_level.is_term) goto 73 nk = 0 call cli$get_value('p1',ascdat,nk) err_status= dix_eval_expression(control,ascdat(1:nk),val, 1 .false.,err_arg,.false.,is_symbol) if(err_status) then c c expression valid, check for type c if(val.type .ne. symb_typ_log) err_status = %loc(dix_msg_invlog) endif if(.not. jump_from_end_statement) then c c We did not come here from the endwhile, so open new level c even if the statement evaluates to false, so the endwhile will clean it c call dix_inter_open_struct(control,file_level,ptrs) p_struct_level = file_level.cur_struct endif if((.not. val.lval) .or. (.not. err_status)) then c c Now evaluates to false, or some other error : jump to endwhile c call memtab_set_line_ptr(file_level.lun,struct_level.ptrs.end_ptr) jump_from_control = .true. endif !evaluates to true jump_from_end_statement = .false. c elseif(verb .eq. 'ENDW') then c c Endwhile c syntax : ENDWHILE c Closing statement of the WHILE/ENDWHILE construct c c if we came here from the while, close struct and continue c else jump bck to while c if(file_level.is_term) goto 73 if(jump_from_control) then c c We can from the while (expression not true) or the LEAVE command c call dix_inter_close_struct(control,file_level) p_struct_level = file_level.cur_struct jump_from_control = .false. else c c We just ran into this one, so jump to the while c if(file_level.struct_level .eq. 0) goto 76 if(struct_level.ptrs.begin_verb .ne. 'WHIL') goto 77 call memtab_set_line_ptr(file_level.lun, 1 struct_level.ptrs.begin_ptr) struct_level.first = .false. jump_from_end_statement = .true. err_status = 1 endif c elseif(verb .eq. 'LOOP') then c c Loop construct c syntax : LOOP c if(file_level.is_term) goto 73 if(jump_from_end_statement) then jump_from_end_statement = .false. else call dix_inter_open_struct(control,file_level,ptrs) p_struct_level = file_level.cur_struct endif c elseif(verb .eq. 'TEST') then c c TESTLOOP c syntax : TESTLOOP expression c c Test statement for the LOOP/TSTLOOP/ENDLOOP construct c if(file_level.is_term) goto 73 c c Test the expression c nk = 0 call cli$get_value('p1',ascdat,nk) err_status= dix_eval_expression(control,ascdat(1:nk),val, 1 .false.,err_arg,.false.,is_symbol) if(err_status) then if(val.type .ne. symb_typ_log) err_status = %loc(dix_msg_notlog) if((.not. err_status) .or. (.not. val.lval)) then call memtab_set_line_ptr(file_level.lun, 1 struct_level.ptrs.end_ptr) jump_from_control = .true. endif endif c elseif(verb .eq. 'ENDL') then c c ENDLOOP c Syntax : ENDLOOP c finishing statement of the LOOP/TESTLOOP/ENDLOOP structure c if(file_level.is_term) goto 73 if(jump_from_control) then c c Came from the TESTLOOP or the LEAVE command c call dix_inter_close_struct(control,file_level) p_struct_level = file_level.cur_struct jump_from_control = .false. else if(file_level.struct_level .eq. 0) goto 76 if(struct_level.ptrs.begin_verb .ne. 'LOOP') goto 77 call memtab_set_line_ptr(file_level.lun, 1 struct_level.ptrs.begin_ptr) jump_from_end_statement = .true. struct_level.first = .false. err_status = 1 endif c elseif(verb .eq. 'FOR') then c c For c syntax : FOR SYMBOL=Initval,Endval[,increment] c starting statement of the FOR/ENDFOR construct c if(file_level.is_term) goto 73 if(.not. jump_from_end_statement) then c c We ran into the FOR, so set up the control c nk = 0 call cli$get_value('p1',ascdat,nk) c c The format : for symbol=begin,end[,interval] c err_status = dix_inter_parse_for(control,ascdat(1:nk),symbol, 1 nk_symb,err_arg,des_expanded, 1 begval,incval,endval) if(.not. err_status) goto 10 c call dix_inter_open_struct(control,file_level,ptrs) p_struct_level = file_level.cur_struct c c FIll in the extra data for the FOR command c struct_level.for_symbol = symbol struct_level.nk_for_symbol= nk_symb struct_level.for_begval = begval struct_level.for_increment= incval struct_level.for_endval = endval workval = begval c c Now define a local symbol, to this level c val.type = symb_typ_int val.ival = begval call dix_eval_sign_extend(val) call dix_symbol_add_level(control,symbol(1:nk_symb), 1 val,err_arg,.true.,'FOR') else c c Now update the symbol c symbol = struct_level.for_symbol nk_symb = struct_level.nk_for_symbol call dix_symbol_find(control,symbol(1:nk_symb),val) val.ival = val.ival + struct_level.for_increment call dix_eval_sign_extend(val) call dix_symbol_add_level(control,symbol(1:nk_symb), 1 val,err_arg,.true.,'FOR') workval = val.ival endif c c And check if we have done it all c if(struct_level.for_increment .gt. 0) then c c Ascending c skip = workval .gt. struct_level.for_endval else c c Descending c skip = workval .lt. struct_level.for_endval endif if(skip) then c c If skip set, jump to beyond ENDFOR, and decrease level c call memtab_set_line_ptr(file_level.lun,struct_level.ptrs.end_ptr) jump_from_control = .true. endif jump_from_end_statement = .false. c elseif(verb .eq. 'ENDF') then c c ENDFOR c SYntax : ENDFOR c closing statement of the FOR/ENDFOR construct c if(file_level.is_term) goto 73 if(jump_from_control) then c c Came from the FOR or the LEAVE command c call dix_inter_close_struct(control,file_level) p_struct_level = file_level.cur_struct jump_from_control = .false. else if(file_level.struct_level .eq. 0) goto 76 if(struct_level.ptrs.begin_verb .ne. 'FOR') goto 77 call memtab_set_line_ptr(file_level.lun, 1 struct_level.ptrs.begin_ptr) struct_level.first = .false. jump_from_end_statement = .true. err_status = 1 endif c elseif(verb .eq. 'REPE') then c c REPEAT c syntax : REPEAT c opening statement of the REPEAT/UNTIL sturcture c if(file_level.is_term) goto 73 c if(.not. jump_from_end_statement) then call dix_inter_open_struct(control,file_level,ptrs) p_struct_level = file_level.cur_struct endif jump_from_end_statement = .false. c elseif(verb .eq. 'UNTI') then c c Until c syntax : UNTIL Leg-expression c Closing statement of the REPEAT/UNTIL structure c if(file_level.is_term) goto 73 if(jump_from_control) then c c Came from the LEAVE statemenet c call dix_inter_close_struct(control,file_level) p_struct_level = file_level.cur_struct jump_from_control = .false. else if(file_level.struct_level .eq. 0) goto 76 if(struct_level.ptrs.begin_verb .ne. 'REPE') goto 77 struct_level.first = .false. nk = 0 call cli$get_value('p1',ascdat,nk) err_status= dix_eval_expression(control,ascdat(1:nk),val, 1 .false.,err_arg,.false.,is_symbol) if(err_status) then if(val.type .ne. symb_typ_log) then err_status = %loc(dix_msg_invlog) val.lval = .true. endif else val.lval = .true. endif if(.not. val.lval) then c c Now evaluates to false, jump to repeat c call memtab_set_line_ptr(file_level.lun, 1 struct_level.ptrs.begin_ptr) jump_from_end_statement = .true. else call dix_inter_close_struct(control,file_level) p_struct_level = file_level.cur_struct endif !evaluates to true endif !jump_from c elseif(verb .eq. 'GOTO') then c c GOTO c Syntax : GOTO label c Goto the specified label c if(file_level.is_term) goto 73 nk_label = 0 call cli$get_value('p1',label,nk_label) err_status = dix_inter_find_label(label, 1 line_level,err_arg,nlevel,file_level, 1 control) if(err_status) then c c We found the label, but is is some levels down, so close all of them c do k=1,nlevel call dix_inter_close_struct(control,file_level) p_struct_level = file_level.cur_struct enddo endif c elseif(verb .eq. 'GOSU') then c c gosub c syntax : GOSUB label c goto the label and let RETURN return you to the next statement c if(file_level.is_term) goto 73 c nk_label = 0 call cli$get_value('p1',label,nk_label) call memtab_get_line_ptr(file_level.lun,gosub_entry.line_nr) c c Insert into link c call dix_util_insert_table(control,file_level.gosubs, 1 gosub_entry,10,file_level.zone_level, 1 'GOSUB_RETURN') c err_status = dix_inter_find_label(label, 1 line_level,err_arg,nlevel,file_level, 1 control) c elseif(verb .eq. 'RETU') then c c RETURN c Syntax : RETURN c Return to the statement just after to GOSUB c if(file_level.is_term) goto 73 if(file_level.gosubs.count .gt. 0) then p_gosub_entries = file_level.gosubs.address line_ptr = gosub_entries(file_level.gosubs.count).line_nr file_level.gosubs.count = file_level.gosubs.count - 1 call memtab_set_line_ptr(file_level.lun,line_ptr) else c c THis is really an error, but DCL lets you enter RETURNS without GOSUBS c so just ignore this c c err_status = %loc(dix_msg_illret) err_status = 1 endif c elseif(verb .eq. 'INQU') then c c Inquire c syntax : INQUIRE statement [prompt_string][/qualifiers c let the user input a value for a symbol c The type of the symbol is defined by the input of the user c err_status = dix_symbol_get_symbol('p1',symbol,nk_symb) if(err_status) then nk = 0 call cli$get_value('p2',line,nk) if(nk .eq. 0) then line = 'Data' nk = 4 endif if(cli$present('punctation')) then line(nk+1:nk+2) = ': ' nk = nk + 2 endif c c Now prompt the user for the input c write(*,1124) line(1:nk) 1124 format('$',a) read(*,2010,iostat=err_status) nk,tline 2010 format(q,a) if(err_status .ne. 0) then call errsns(,err_status) else err_status= dix_eval_expression(control,tline(1:nk),val, 1 .false.,err_arg,.false.,is_symbol) endif if(err_status) then call dix_symbol_add(control,symbol(1:nk_symb),val,err_arg) endif else err_arg = symbol(1:nk_symb) endif !valid symbol name c elseif(verb .eq. 'CREA') then c c CREATE c syntax : create what (what = DESCRIPTION or RECORD) c Create description file or new record in the file c nk = 0 call cli$get_value('p1',line,nk) if(line(1:1) .eq. 'D') then c c We want to create a description c nk = 0 call cli$get_value('p2',line,nk) err_status = dix_util_check_name(line(1:nk)) if(err_status) then where = des_in_file if(cli$present('user_library' )) where = des_in_userlib if(cli$present('system_library')) where = des_in_syslib k = control.editor !take the default if(cli$present('internal')) k = dix_edit_internal if(cli$present('edt')) k = dix_edit_edt if(cli$present('tpu')) k = dix_edit_tpu err_status = dix_edit_des(control,file,des_info,line(1:nk), 1 where,err_arg,k) endif else c c We want to create a new record in the file c err_status = dix_dump_inter_get_file(control,'p1',k,err_arg) if(err_status) then p_temp_file = k if(.not. temp_file.modify) goto 75 call dix_main_fill_rec(control,temp_file) temp_file.data.newrec = .true. call dix_des_inv_des(control,temp_file) endif endif c elseif(verb .eq. 'DUMP') then if(%loc(file) .eq. 0) goto 71 c c Sabve ncols and set it to max c save_ncols = control.ncols control.ncols = max_command_length err_status = dix_dump_i_open_output(control,save_lun,save_paged, 1 err_arg,dis.is_term,file_level) if(err_status) then call dix_main_parse_csv(control) call cli$get_value('count',line,nk) read(line(1:nk),2011) file.count 2011 format(i10) call dix_main_get_list(control,'SELECT', 1 control.lun_select,.false.) if(cli$present('rewind')) err_status = 1 dix_rms_rewind(control,file,-1) c c Set standard display parameters c dis_work = dis call dix_inter_set_display(dis_work,.false.) if(err_status) then err_status = dix_dump_file(control,file,k,dis_work,.false.) endif c call dix_dump_i_close_output(control,save_lun, 1 save_paged,file_level, 1 'Show Descriptor') endif c c Restore cols c control.ncols = save_ncols elseif(verb .eq. 'EDIT') then c c EDIT c EDIT SEARCH c syntax : EDIT [SEARCH] c Edit current description file c err_status = 1 call cli$get_value('p1',line) if(line(1:1) .eq. 'S') then if(control.is_term) then k = control.smg_window control.smg_window = 1 call dix_search_set_screen(control) control.smg_window = k else err_status = %loc(dix_msg_noscreen) endif else if(%loc(file) .eq. 0) goto 71 if(file.cur_des .eq. 0) goto 72 k = control.editor !take the default if(cli$present('internal')) k = dix_edit_internal if(cli$present('edt')) k = dix_edit_edt if(cli$present('tpu')) k = dix_edit_tpu err_status = dix_edit_des(control,file,des_info,' ',0,err_arg,k) c c Clear expand flag for all file/des that use this description c call dix_des_inv_des_all(control,des_info) endif c elseif(verb .eq. 'SHOW') then c c SHOW c Syntax : SHOW what c Show some things c call cli$get_value('p1',line) c dis_work = dis c if(line(1:3) .eq. 'PAG') then c c Show pagemode c temp = 'No' if(control.paged .eq. 1) temp = 'Yes' if(control.paged .eq. 3) temp = 'Screen' call dix_dump_print_line(control,0, 1 'Page mode set to '//temp(1:6)) elseif(line(1:2) .eq. 'SU') then c c Show substitute c nk = 0 if((control.inter_control .and. substitute_verb) .ne. 0) 1 call dix_append(nk,temp,'Verb,') if((control.inter_control .and. substitute_symbols) .ne. 0) 1 call dix_append(nk,temp,'Symbols,') if(nk .eq. 0) then call sys$fao('Nothing,',nk,line) endif call dix_dump_print_line(control,0, 1 'Symbol substitution set to '//temp(1:nk-1)) elseif(line(1:2) .eq. 'SE') then c c Show search c call dix_search_show(control) elseif(line(1:2) .eq. 'SK') then c c Show skeys c k = 0 nk = 0 nk_t = 0 call cli$get_value('output',line,nk) call cli$get_value('context_screen',context,nk_t) call cli$get_value('p2',temp,k) if(k .eq. 0) call sys$fao('*',k,temp) if(nk_t .gt. 0) call dix_append(nk_t,context,'*') call keydefs_dump(control,line(1:nk), 1 context(1:nk_t),temp(1:k)) elseif(line(1:4) .eq. 'KEYB') then c c Display the keyboard setting c temp = 'Normal' if(control.keyboard .eq. keyboard_pc) temp = 'PC' if(control.keyboard .eq. keyboard_laptop) temp = 'Laptop' call dix_dump_print_line(control,0, 1 'Keyboard type set to '//temp(1:6)) c elseif(line(1:4) .eq. 'KEYS') then c c Show keys c call dix_inter_list_keys(control) elseif(line(1:2) .eq. 'ST') then c c Show strict c call dix_inter_conv_strict(file_level.strict_mode,line,nk) call dix_dump_print_line(control,0, 1 'Strict mode set to '//line(1:nk)) elseif(line(1:3) .eq. 'REL') then c c Show release notes c err_status = dix_dump_int_show_rel(control,err_arg, 1 file_Level,dis_work) elseif(line(1:1) .eq. 'I') then c c Show integer format/size c call sys$fao('Current integer_size = !UL',nk,line, 1 %val(control.integer_size)) call dix_dump_print_line(control,0,line(1:nk)) call sys$fao(' Size !2UL format !AS',nk,line, 1 %val(4),control.format_integer4) call dix_dump_print_line(control,0,line(1:nk)) if(control.platform .ne. platform_vax) then call sys$fao(' Size !2UL format !AS',nk,line, 1 %val(8),control.format_integer8) call dix_dump_print_line(control,0,line(1:nk)) endif elseif(line(1:3) .eq. 'REA') then c c show real format/size c call sys$fao('Current real_size = !UL',nk,line, 1 %val(control.real_size)) call dix_dump_print_line(control,0,line(1:nk)) c call dix_con_cvt_float_type(control,4,k) call dix_con_float_name(k,symbol) call sys$fao(' Size !2UL type !AS format !AS',nk,line, 1 %val(4),symbol(1:6),control.format_real4) call dix_dump_print_line(control,0,line(1:nk)) c call dix_con_cvt_float_type(control,8,k) call dix_con_float_name(k,symbol) call sys$fao(' Size !2UL type !AS format !AS',nk,line, 1 %val(8),symbol(1:6),control.format_real8) call dix_dump_print_line(control,0,line(1:nk)) c call dix_con_cvt_float_type(control,16,k) call dix_con_float_name(k,symbol) call sys$fao(' Size !2UL type !AS format !AS',nk,line, 1 %val(16),symbol(1:6),control.format_real16) call dix_dump_print_line(control,0,line(1:nk)) elseif(line(1:2) .eq. 'DI') then c c Show display settings c call dix_inter_show_dis(control,dis_work) elseif(line(1:3) .eq. 'DEC') then if(control.decimal_round) then temp = 'Rounded' else temp = 'Truncated' endif call sys$fao('Decimal is set to /DIGITS=!UL/!AS', 1 nk,line,%val(control.decimal_ndig), 1 temp(1:9)) call dix_dump_print_line(control,0,line(1:nk)) elseif(line(1:3) .eq. 'DEB') then c c Show debug c call dix_main_debug_show(control,line,nk) if(nk .eq. 0) call sys$fao('NONE',nk,line) call dix_dump_print_line(control,0, 1 'Debug for : '//line(1:nk)) elseif(line(1:3) .eq. 'DES') then c c Show decription c err_status = dix_dump_i_open_output(control,save_lun,save_paged, 1 err_arg,dis.is_term,file_level) if(err_status) then if(cli$present('expanded')) then if(%loc(des_info) .eq. 0) goto 72 if(des_expanded.table_vfc.count .gt. 0) then call dix_dump_print_line(control,0, 1 'VFC data desciptions') err_status = dix_dump_i_show_des_exp(control, 1 des_expanded.table_vfc.count, 1 %val(des_expanded.table_vfc.address), 1 des_info.has_fields,des_info.first_vfc_var) if(err_status) call dix_dump_print_line(control,0, 1 'Normal data desciptions') endif if(err_status) err_status = dix_dump_i_show_des_exp(control, 1 des_expanded.table_nor.count, 1 %val(des_expanded.table_nor.address), 1 des_info.has_fields,des_info.first_nor_var) else err_status = dix_dump_i_show_des(control,file,des_info) endif endif call dix_dump_i_close_output(control,save_lun, 1 save_paged,file_level, 1 'Show Descriptor') elseif(line(1:1) .eq. 'E') then c c Show editor c temp = 'Unknown' if(control.editor .eq. dix_edit_edt ) temp = 'EDT' if(control.editor .eq. dix_edit_internal) temp = 'Internal' if(control.editor .eq. dix_edit_tpu ) temp = 'TPU' call dix_dump_print_line(control,0, 1 'Editor set to '//temp(1:8)) elseif(line(1:1) .eq. 'T') then c c Show terminal c nk = 0 if((control.input_flags .and. input_flag_editing) .eq. 0) then call dix_append(nk,line,'NO') endif call dix_append(nk,line,'LINE_EDITING') if((control.input_flags .and. input_flag_insert) .eq. 0) then call dix_append(nk,line,',OVERSTRIKE') else call dix_append(nk,line,',INSERT') endif call dix_dump_print_line(control,0, 1 'Terminal set to '//line(1:nk)) elseif(line(1:3) .eq. 'FIN') then c c Show find c err_status = dix_dump_i_open_output(control,save_lun,save_paged, 1 err_arg,dis.is_term,file_level) if(err_status) then call dix_search_show(control) call dix_dump_i_close_output(control,save_lun, 1 save_paged,file_level, 1 'Show Find') endif elseif(line(1:3) .eq. 'FIL') then c c Show file c err_status = dix_dump_i_open_output(control,save_lun,save_paged, 1 err_arg,dis.is_term,file_level) if(err_status) then do_descr = cli$present('descriptions') all = cli$present('ALL') full = cli$present('FULL') if(all) then if(control.n_file .eq. 0) goto 71 else if(%loc(file) .eq. 0) goto 71 endif call dix_dump_inter_dir_files(control,full,do_descr,all) endif call dix_dump_i_close_output(control,save_lun, 1 save_paged,file_level, 1 'Show File') elseif(line(1:3) .eq. 'FOR') then c c Show format (binary data) c temp = 'passall' if(control.include_binary .eq. include_binary_dot) temp = 'dot' if(control.include_binary .eq. include_binary_fancy)temp= 'dump' if(control.include_binary .eq. include_binary_hex) temp = 'hex' call dix_dump_print_line(control,0, 1 'Binary conversion set to '//temp(1:6)) elseif(line(1:2) .eq. 'SY') then c c Show symbols c if(cli$present('statistics')) then full = cli$present('full') all = cli$present('all') call dix_symbol_statistics(control,full,all) else dis_work.hex = dis.hex call dix_inter_set_hex_mode(dis_work.hex) nk_line = 0 call cli$get_value('p2',line,nk_line) all = cli$present('ALL') full = cli$present('FULL') call dix_dump_show_symbols(control, 1 line(1:nk_line),dis_work.hex,all,full) endif elseif(line(1:1) .eq. 'P') then c c Show parameters c if(%loc(des_info) .eq. 0) goto 72 err_status = dix_dump_i_open_output(control,save_lun,save_paged, 1 err_arg,dis.is_term,file_level) if(err_status) then dis_work.hex = dis.hex call dix_inter_set_hex_mode(dis_work.hex) nl = 0 nk_line = 0 call cli$get_value('p2',line,nk_line) if(nk_line .eq. 0) then line = '*' nk_line = 1 endif call dix_dump_print_par(control,des_info.parameters.count, 1 %val(des_info.parameters.address),line(1:nk_line), 1 dis_work.hex) endif call dix_dump_i_close_output(control,save_lun, 1 save_paged,file_level, 1 'Show Parameters') elseif(line(1:2) .eq. 'VI') then c c Show virtual memory c err_status = dix_dump_i_open_output(control,save_lun,save_paged, 1 err_arg,dis.is_term,file_level) if(err_status) then if(cli$present('VMS')) then full = cli$present('full') all = cli$present('detail') call vm_info(control,full,all) elseif(cli$present('LINK')) then call dix_util_show_vm_link(control) else call dix_util_show_vm(control) endif call dix_dump_i_close_output(control,save_lun, 1 save_paged,file_level, 1 'Virtual memory info') endif elseif(line(1:2) .eq. 'VE') then c c Show version c call dix_get_version(line,nk) call dix_dump_print_line(control,0, 1 'DIX Version '//line(1:nk)) elseif(line(1:2) .eq. 'ME') then c c Show message c call dix_inter_conv_msg(control.msgmask,line,nk) call dix_dump_print_line(control,0, 1 'Message set to '//line(1:nk)) elseif(line(1:2) .eq. 'MO') then c c Show mouse c line = 'Off' if(control.use_mouse) line = 'On' call dix_dump_print_line(control,0, 1 'Mouse usage set to '//line(1:3)) else goto 70 endif c elseif(verb .eq. 'SET') then c c Set c Syntax : set what towhat c Set something c call cli$get_value('p1',line) if(line(1:2) .eq. 'FO' ) then !set format c c Set format (binary data) c call cli$get_value('p2',line) control.include_binary = include_binary_dot if(line(1:1) .eq. 'P')control.include_binary=include_binary_bin if(line(1:2) .eq. 'DU')control.include_binary=include_binary_fancy if(line(1:1) .eq. 'H')control.include_binary=include_binary_hex elseif(line(1:1) .eq. 'O' ) then !set on c c Set on c call dix_inter_set_default_error(file_level) elseif(line(1:3) .eq. 'NOO' ) then !set on c c Set noon c file_level.on_mode = .false. elseif(line(1:2) .eq. 'DI' ) then c c Set display c call dix_inter_set_display(dis,.true.) elseif(line(1:3) .eq. 'DEC' ) then c c#### Set count of decimal digits c if(cli$present('ROUNDED')) control.decimal_round = .true. if(cli$present('TRUNCATED')) control.decimal_round = .false. call cli$get_value('digits',line,nk) if(nk .gt. 0) then read(line(1:nk),'(bn,i10)',iostat=err_status) k if(err_status .ne. 0) then err_status = %loc(dix_msg_illdigits) else if(k .lt. 0 .or. k .gt. 255) then err_status = %loc(dix_msg_illdigits) else control.decimal_ndig = k err_status = 1 endif endif if(.not. err_status) err_arg = line(1:nk) endif elseif(line(1:3) .eq. 'DEB' ) then c c Set debug c call dix_main_debug('p2',control) elseif(line(1:2) .eq. 'FI' ) then c c Set file c if(control.top_file .eq. 0) goto 71 err_status = dix_inter_set_file(control,err_arg) elseif(line(1:1) .eq. 'V' ) then c c Set verify c file_level.verify = .true. elseif(line(1:3) .eq. 'NOV') then c c Set noverify c file_level.verify = .false. elseif(line(1:2) .eq. 'ME') then c c Set message c call set_message(control) elseif(line(1:2) .eq. 'MO') then c c Set mouse c call dix_startup_set_mouse(control) elseif(line(1:2) .eq. 'ED') then c c Set editor c call cli$get_value('p2',line) if(line(1:1) .eq. 'E') then control.editor = dix_edit_edt elseif(line(1:1) .eq. 'I') then control.editor = dix_edit_internal elseif(line(1:1) .eq. 'T') then control.editor = dix_edit_tpu endif elseif(line(1:2) .eq. 'EX') then c c Set exit number c nk = 0 call cli$get_value('p2',line,nk) read(line(1:nk),2040) err_status 2040 format(i10) elseif(line(1:1) .eq. 'K') then c cSet keyboard c call cli$get_value('p2',temp) if(temp .ne. ' ') then control.keyboard =keyboard_normal if(temp(1:1) .eq. 'P') control.keyboard =keyboard_pc if(temp(1:1) .eq. 'L') control.keyboard =keyboard_laptop endif elseif(line(1:4) .eq. 'PROM') then c c Set prompt c call cli$get_value('P2',control.prompt,control.nk_prompt) elseif(line(1:4) .eq. 'PROC') then c c set process/name=xyz c call cli$get_value('NAME',line,nk) if(nk .gt. 0) then nk = min(nk,15) err_status = sys$setprn(line(1:nk)) endif elseif(line(1:2) .eq. 'PA') then c c Set page no/yes/screen c nk = 0 call cli$get_value('p2',line,nk) if(line(1:1) .eq. 'N') control.paged = 0 if(line(1:1) .eq. 'Y') control.paged = 1 if(line(1:1) .eq. 'S') control.paged = 3 temp = 'No' if(control.paged .eq. 1) temp = 'Yes' if(control.paged .eq. 3) temp = 'Screen' call dix_message(control,dix_msg_pagemode,temp) elseif(line(1:1) .eq. 'R') then c c Set real formats c err_status = dix_startup_set_real(control,err_arg) elseif(line(1:1) .eq. 'I') then c c Set integer formats c err_status = dix_startup_set_integer(control,err_arg) elseif(line(1:2) .eq. 'SU') then c c Set substitute /verb/symbols c call dix_util_set_bit_flag('verb', 1 control.inter_control,substitute_verb,.false.) call dix_util_set_bit_flag('symbols', 1 control.inter_control,substitute_symbols,.false.) elseif(line(1:2) .eq. 'SE' ) then c c Set search c err_status = dix_search_set_flags(control,2,8) elseif(line(1:2) .eq. 'SC') then c c Set screen c if(%loc(file) .eq. 0) goto 71 iterm = key_modechange elseif(line(1:2) .eq. 'ST') then c c Set strict mode c The symbol routines make use of the c control.strict_mode, so keep it in sync c call set_strict(file_level.strict_mode) control.strict_mode = file_level.strict_mode elseif(line(1:1) .eq. 'T') then c c Set terminal/line c call dix_util_set_bit_flag('LINE_editing', 1 control.input_flags,input_flag_editing,.false.) call dix_util_set_bit_flag('INSERT', 1 control.input_flags,input_flag_insert,.false.) call dix_util_set_bit_flag('OVERSTRIKE', 1 control.input_flags,input_flag_insert,.true.) c call cli$get_value('width',line,nk) if(nk .gt. 0) then read(line(1:nk),'(bn,i10)',iostat=err_status) k if(k .lt. 40 .or. k .gt. max_screen_width) err_status = 1 if(err_status .ne. 0) then err_status = %loc(dix_msg_illwidth) else control.ncols = k call smg$change_pbd_characteristics(control.paste_id, 1 k,control.ncols) call dix_message(control,dix_msg_widthset, 1 %val(control.ncols)) err_status = 1 endif endif else goto 70 endif c elseif(verb .eq. 'ECHO') then c c Echo c Syntax ECHO[/console] "string" c Print a string to the output file/terminal c nk_t = 0 call cli$get_value('p1',line,nk_t) if(line(1:1) .eq. '"' .and. line(nk_t:nk_t) .eq. '"') then line = line(2:nk_t-1) nk_t = nk_t - 2 endif k = 0 if(cli$present('console')) then k = file_level.lun_out file_level.lun_out = control.lun_console endif call dix_dump_print_line(control,0,'ECHO:'//line(1:nk_t)) if(k .ne. 0) file_level.lun_out = k c elseif(verb .eq. 'SPAW') then c c SPAWN c Syntax : SPAWN [command] c The spawn command, temporary to DCL c nk = 0 call cli$get_value('p1',line,nk) call lib$spawn(line(1:nk)) c elseif(verb .eq. 'HELP') then c c HELP c Syntax : HELP [topic [topic...] c The help command c nk = 0 call cli$get_Value('p1',line,nk) call dix_help('DIX INTERACTIVE '//line(1:nk)) c elseif(verb .eq. 'ON') then c c ON c Syntax : ON CONTROL_C command c ON severity command (severity = warning,error,severe) c Define action for some events c if(file_level.is_term) goto 73 nk = 0 call cli$get_value('P1',line,nk) file_level.on_mode = .true. if(line(1:1) .eq. 'C') then c c On control c call cli$get_value('P2',file_level.on_control_c_line) else c c On warning,error,severe c call cli$get_value('P2',file_level.on_line) if(line(1:1) .eq. 'W') then file_level.on_level = sts$k_warning elseif(line(1:1) .eq. 'E') then file_level.on_level = sts$k_error elseif(line(1:1) .eq. 'S') then file_level.on_level = sts$k_severe endif endif c elseif(verb .eq. 'EVAL') then c c Evaluate c Syntax : Evaluate expression c Evaluatie expression and print the result c dis_work.hex = dis.hex call dix_inter_set_hex_mode(dis_work.hex) nk = 0 call cli$get_value('p1',ascdat,nk) call dix_util_collapse(ascdat,nk,.true.) nk_tot = 0 42 err_status= dix_eval_expression1(control,ascdat(1:nk),val, 1 .false.,err_arg,.false.,kar,l,is_symbol) if(err_status) then call dix_con_value_intasc(control,val, 1 eval_line(nk_tot+1:),k,dis_work.hex) nk_tot = nk_tot + k if(kar .eq. ',') then ascdat = ascdat(l:) nk = nk - l + 1 goto 42 elseif(kar .eq. NULL) then call dix_dump_print_line(control,0,eval_line(1:nk_tot)) else err_status = %loc(dix_msg_unexpchar) err_arg = kar endif endif c elseif(verb .eq. 'IF') then c c IF c Syntax : IF (log_expr) command One line if c or : IF (log_expr) THEN Start statement of IFTHEN/ELSE/ENDIF construct c find the (expr) part c nk = 0 call cli$get_value('p1',line,nk) if(line(1:1) .eq. '(') then k = dix_util_find_char_bracket(line,')',.true.) if(k .le. 2) then err_status = %loc(dix_msg_closbnotf) goto 10 endif c totline = line(k+1:) !remember the command nk_tot = nk - k + 1 c c Evaluate the expression c err_status = dix_eval_expression(control, 1 line(2:k-1),val1, 1 .false.,err_arg,.false.,is_symbol) if(err_status) then if(val1.type .ne. symb_typ_log) then err_status = %loc(dix_msg_notlog) err_arg = line(1:k) endif endif if(err_status) then istat = val1.lval call dix_util_decent_line(nk_tot,totline) then_mode = totline .eq. 'THEN' c if(then_mode) then if(file_level.is_term) goto 73 call dix_inter_open_struct(control,file_level,ptrs) p_struct_level = file_level.cur_struct c c We have the ifthen variant c if(.not. istat) then c c Take the else branch if there, else take the endif c line_ptr = struct_level.ptrs.middle_ptr if(line_ptr .eq. 0) then c c No ELSE branch, so continue after the ENDIF, and exit this IF level c line_ptr = struct_level.ptrs.end_ptr endif jump_from_control = .true. call memtab_set_line_ptr(file_level.lun,line_ptr) endif c c IF (EXPR) THEN : expr evaluates to true, so just continue c else c c IF (EXPR) statement c if(istat) then c c EXPR is .true. Make sure all items are parsable c call dix_inter_massage(totline,nk_tot) goto 25 !valid result, go execute totline endif endif endif else err_status = %loc(dix_msg_openbnotf) endif c elseif(verb .eq. 'ELSE') then c c ELSE c Syntax : ELSE c ELSE statement of the IFTHEN/ELSE/ENDIF structure c if(file_level.is_term) goto 73 if(jump_from_control) then jump_from_control = .false. !we came from if else call memtab_set_line_ptr(file_level.lun,struct_level.ptrs.end_ptr) err_status = 1 endif c elseif(verb .eq. 'ENDI') then c c ENDIF c syntax :ENDIF c closing statement of the IFTHE/ELSE/ENDIF statement c jump_from_control = .false. if(file_level.is_term) goto 73 if(file_level.struct_level .eq. 0) goto 76 if(struct_level.ptrs.begin_verb .ne. 'IF') goto 77 call dix_inter_close_struct(control,file_level) p_struct_level = file_level.cur_struct c elseif(verb .eq. 'DELE') then c c DELETE c Syntax : DELETE /symbol symbolname delete symbols c : DELETE /key keyname Delete keys for interactive mode c : DELETE /skey keyname Delete keys for screen mode c : DELETE Delete record c if(cli$present('symbol')) then err_status = dix_symbol_get_symbol('p1',line,nk_line) if(err_status) then logit = cli$present('log') all = .not. cli$present('local') err_status = dix_symbol_delete(control,line(1:nk_line), 1 logit,.false.,all) else err_arg = line(1:nk_line) endif elseif(cli$present('RECORD')) then if(%loc(file) .eq. 0) goto 71 p_temp_file = %loc(file) err_status = dix_rms_delete(control,file) call dix_des_inv_des(control,temp_file) elseif(cli$present('KEY')) then nk = 0 call cli$get_value('p1',line,nk) nk_if = 0 call cli$get_value('state',if_state,nk_if) err_status = smg$delete_key_def(control.keytable_id, 1 line(1:nk),if_state(1:nk_if)) elseif(cli$present('SKEY')) then if(cli$present('all')) then if_state = ' ' line = ' ' else call cli$get_value('p1',line) call cli$get_value('state',if_state,nk) call cli$get_value('context_screen',context,nk_t) endif call keydefs_del_key(control,line,if_state(1:nk), 1 context(1:nk_t)) else goto 70 endif c elseif(verb .eq. 'READ') then c c READ c syntax : READ [tag] [/error=label][/end=label][record selection quals] c Read a record from the file c call dix_dump_get_err_lab(control,file_level) call dix_dump_get_eof_lab(control,file_level) trans = cli$present('translate') err_status = dix_dump_inter_get_file(control,'p1',k,err_arg) if(err_status) then p_temp_file = k c err_status = dix_dump_i_get_keys(temp_file,control,err_arg,trans) err_status = dix_main_get_keyvals(control,temp_file, 1 k,trans,.false.,err_arg) end if elseif(verb .eq. 'CLOS') then c c CLOSE c Syntax : CLOSE [/ERROR=label] [mask] c Close the current file c call dix_dump_get_err_lab(control,file_level) logit = cli$present('log') nk = 0 call cli$get_value('p1',line,nk) if(nk .eq. 0) then c c Now take the current file only c if(%loc(file) .eq. 0) goto 71 line = file.handle nk = file.nk_handle endif c call dix_main_close_files(control,line(1:nk),logit) elseif(verb .eq. 'MARK') then c c MARK c Syntax : MARK [markname] c mark this record for easy retrieval c if(%loc(file) .eq. 0) goto 71 nk = 0 call cli$get_value('p1',tline,nk) call dix_rms_save_rfa_rab(control,tline(1:nk), 1 %val(file.rabadr),file.rec_nr) c elseif(verb .eq. 'GOMA') then c c GOMARK c syntax : GOMARK [markname] c Goto a previously save RECORD marker c nk = 0 call cli$get_value('p1',tline,nk) if(.not. dix_rms_check_rfa(tline(1:nk))) then err_arg = tline(1:nk) err_status = %loc(dix_msg_mrknotmrk) else err_arg = tline(1:nk) err_status = dix_main_rfa_restore(control,tline(1:nk)) endif c elseif(verb .eq. 'EXAM' .or. verb .eq. 'FIND') then c c EXAM or SEAR c Syntax: EXAMINE [/qualifiers] [fieldmask] Display fields c SEARCH [/qualifiers] [searchmask] Display field with contents c err_status = dix_dump_i_exam(control,dis,verb,err_arg, 1 file_level) c elseif(verb .eq. 'DEPO') then c c Deposit c Syntax: DEPOSIT[/qualifiers] fieldname=value c DEPOSIT[/qualifiers] offset=value c Deposit data in fields or raw byte offsets c p_temp_file = %loc(file) err_status = dix_dump_i_depo(control,dis, 1 err_arg,ototline(1:onk_tot)) c elseif(verb .eq. 'TRUN') then c c TRUNCATE c Syntax TRUNCATE[/qualifiers] size c Or TRUNCATE[/qualifiers[ tag size c c Truncate the current record (only IDX and REL files) c nk_field = 0 if(cli$present('p2')) then c c 2 parameters specified, tag, recl c err_status = dix_dump_inter_get_file(control,'p1',k,err_arg) call cli$get_value('p2',fieldname,nk_field) else c c Only one paramter recl c k = control.cur_file call cli$get_value('p1',fieldname,nk_field) endif c if(k .eq. 0) goto 71 c p_temp_file = k c c Check if allowed c if(.not. temp_file.modify) goto 75 if(.not. ((temp_file.indexed .or. temp_file.relative) .and. .not. 1 temp_file.fixed)) then err_status = %loc(dix_msg_cannotchg) else dis_work.number_hex = cli$present('HEX') if(dix_con_i4(fieldname(1:nk_field),nk_field, 1 offs,dis_work.number_hex, 1 control,.false.)) then offs = max(temp_file.minrecl,offs) if(temp_file.maxrecl .ne. 0) then offs = min(temp_file.maxrecl,offs) endif temp_file.data.nb_data = offs call dix_message(control,dix_msg_chgdrecl, 1 %val(temp_file.data.nb_data)) call dix_des_inv_des(control,temp_file) else err_arg = fieldname(1:nk_field) err_status = %loc(dix_msg_illoffs) end if endif !correct file type c elseif(verb .eq. 'REWI') then c c REWIND c Syntax : REWIND [/KEY=keynumber] [tag] c c Rewind a file to the first record [on the specified key] c the first record is read and is the current record c err_status = dix_dump_inter_get_file(control,'p1',k,err_arg) if(err_status) then p_temp_file = k if(cli$present('KEY')) then if(temp_file.indexed) then call util_cli_get_number('KEY',0,key) if(key .lt. 0 .or. key .ge. temp_file.nkey) then call cli$get_value('key',err_arg) err_status = %loc(dix_msg_illkey) endif else err_status = %loc(dix_msg_notindex) endif else key = -1 endif if(err_status) err_status = dix_rms_rewind(control,temp_file,key) if(err_status) err_status = dix_rms_get(control,temp_file) endif elseif(verb .eq. 'WRIT') then if(%loc(file) .eq. 0) goto 71 call cli$get_value('p1',line) descr(1) = file.data.nb_data descr(2) = %loc(file.data.data_rec) do_append = cli$present('append') err_status = dix_dump_i_wrfile(line,do_append, 1 file.data.nb_data, 1 file.data.data_rec) elseif(verb .eq. 'UPDA') then c c UPDATE c syntax : UPDATE[/quiet] c Or : UPDATE[/quiet] tag c Update the current data in memory to the file c if(cli$present('p1')) then err_status = dix_dump_inter_get_file(control,'p1',k,err_arg) else k = control.cur_file endif if(k .eq. 0) goto 71 p_temp_file = k if(.not. temp_file.modify) goto 75 c signal = .true. if(cli$present('quiet')) signal = .false. err_status = dix_rms_update(control,temp_file,signal) c elseif(verb .eq. 'CUT' .or. verb .eq. 'COPY') then c c CUT c Syntax : CUT [TAG] [/SYMBOL=symbolname] c Save the record data to the save area (paste buffer) c err_status = dix_dump_inter_get_file(control,'p1',k,err_arg) if(err_status) then p_temp_file = k err_status = dix_symbol_get_symbol('symbol',symbol,nk_symb) if(err_status) then if(nk_symb .gt. 0) then descr(1) = temp_file.data.nb_data descr(2) = %loc(temp_file.data.data_rec) if(cli$present('dcl')) then k = 1 if(cli$present('global')) k= 2 err_status = lib$set_symbol(symbol(1:nk_symb),descr,k) else err_status = dix_symbol_add_str(control,symbol(1:nk_symb), 1 descr,err_arg) endif if(err_status) then call dix_message(control,dix_msg_datasav, 1 %val(temp_file.data.nb_data), 1 %DESCR('symbol '//symbol(1:nk_symb))) endif else control.nb_save = temp_file.data.nb_data call dix_util_copy(temp_file.data.nb_data, 1 temp_file.data.data_rec, 1 control.save_area) call dix_message(control,dix_msg_datasav, 1 %val(temp_file.data.nb_data),%DESCR('SAVE_AREA')) endif else err_arg = symbol(1:nk_symb) endif endif c elseif(verb .eq. 'PAST') then c c PASTE c Syntax : PASTE [TAG] [/symbol=expression] c Replace the record data in memory by data from the save area (past buffer) c or from data in a symbol c err_status = dix_dump_inter_get_file(control,'p1',k,err_arg) if(err_status) then p_temp_file = k if(.not. temp_file.modify) goto 75 if(cli$present('SYMBOL')) then nk = 0 call cli$get_value('symbol',ascdat,nk) if(cli$present('dcl')) then k = 1 if(cli$present('global')) k = 2 err_status = lib$get_symbol(ascdat(1:nk),val.strdes,k) val.type= symb_typ_char else err_status= dix_eval_expression(control,ascdat(1:nk),val, 1 .false.,err_arg,.false.,is_symbol) endif if(err_status) then if(val.type .eq. symb_typ_char) then temp_file.data.nb_data = zext(val.strdes.dsc$w_maxstrlen) call dix_util_copy(temp_file.data.nb_data, 1 %val(val.strdes.dsc$a_pointer), 1 temp_file.data.data_rec) call dix_message(control,dix_msg_datarest, 1 %val(temp_file.data.nb_data), 1 %descr('Symbol '//ascdat(1:nk))) call dix_des_inv_des(control,temp_file) else err_status = %loc(dix_msg_notchar) endif endif else if(control.nb_save .eq. 0) then err_status = %loc(dix_msg_norest) else temp_file.data.nb_data = control.nb_save call dix_util_copy(temp_file.data.nb_data,control.save_area, 1 temp_file.data.data_rec) call dix_message(control,dix_msg_datarest, 1 %val(temp_file.data.nb_data), 1 %descr('SAVE_AREA')) call dix_des_inv_des(control,temp_file) endif end if endif c elseif(verb .eq. 'ADD') then c c Add c Syntax : ADD description[,description...] c Add new descriptions to the current open file c if(%loc(file) .eq. 0) goto 71 c c Add another description file to to current file c nk_line = 0 call memtab_init(control,lun1,'TEMP_DES') do while (cli$get_value('description',line,nk_line)) kar = 'N' if(cli$present('all')) kar = 'Y' call memtab_add_record(control,lun1,kar//line(1:nk_line)) end do call memtab_rewind(lun1) do while (memtab_read(lun1,nk_line,line)) all = line(1:1) .eq. 'Y' if(.not. dix_des_get_all(control,file,line(2:nk_line), 1 .true.,all)) then call dix_message(control,dix_msg_notaddes,line(2:nk_line)) endif end do call memtab_close(control,lun1) c if(file.cur_des .eq. 0) then file.cur_des = file.top_des if(file.cur_des .ne. 0) then dis.hex = des_flag_translate_nor !assume decimal display endif endif c elseif(verb .eq. 'BACK') then c c BACK c SYNTAX : BACK [/log][/error=label] c Follow the backlink from a previous FOLLOW statement c if(%loc(file) .eq. 0) goto 71 logit = cli$present('log') call dix_dump_get_err_lab(control,file_level) err_status = dix_main_follow_back(control,logit) c elseif(verb .eq. 'FOLL') then c c FOLLOW c Syntax : FOLLOW fieldname[/log] c Follow the link specified in the fieldname to another record in c (possibly) another file. c if(%loc(file) .eq. 0) goto 71 if(p_des_expanded .eq. 0) goto 72 if(des_expanded.expand_error) goto 72 c logit = cli$present('log') nk_line = 0 call cli$get_value('p1',line,nk_line) call dix_dump_get_err_lab(control,file_level) l = 0 p_des_recs = des_expanded.table_nor.address do k=1,des_expanded.table_nor.count if(dix_util_str_eq(line(1:nk_line),des_recs(k).nam)) then l = k end if end do if(l .eq. 0) then err_status = %loc(dix_msg_fieldnotf) err_arg = line else err_status = dix_dump_set_link(control,l, 1 %val(des_expanded.table_nor.address), 1 err_arg,file,logit,link_rec, 1 val,link_fnam) if(err_status) then auto = cli$present('automatic') flag = 0 !assume open a current file if(cli$present('write')) flag = 1 !open /write if(cli$present('read')) flag = -1 !open /nowrite err_status = dix_main_follow(control,auto,flag, 1 link_rec,val,link_fnam,err_arg) endif endif c elseif(verb .eq. 'REMO') then c c REMOVE c Syntax : REMOVE description[,description] c Remove descriptions from the current file c if(%loc(file) .eq. 0) goto 71 nk_line = 0 call cli$get_value('p2',line,nk_line) p_des_expanded = file.top_des do_sys = cli$present('system_library') do_usr = cli$present('user_library') do_fil = cli$present('file') c 121 ptr_desc = -1 do while(dix_dump_inter_next_descr(file,ptr_desc, 1 line(1:nk_line),wildcard_flag_standard,.false.)) p_des_expanded = ptr_desc p_des_info = des_expanded.p_des_info do_it = 1 ((des_info.in_Library.eq.des_in_file ).and.do_fil).or. 1 ((des_info.in_Library.eq.des_in_syslib ).and.do_sys).or. 1 ((des_info.in_Library.eq.des_in_userlib).and.do_usr) if(do_it) then call dix_message(control,dix_msg_desrem, 1 des_info.fnam(1:des_info.nk_fnam)) call dix_des_link_out(control,file,des_expanded) goto 121 end if end do if(file.top_des .eq. 0) then call dix_message(control,dix_msg_nomordes) dis.hex = des_flag_translate_hex endif file.cur_des = file.top_des !select new description c elseif(verb .eq. 'UNDO') then c c UNDO c Syntax : UNDO c Or : UNDO tag c undo changes made to record c err_status = dix_dump_inter_get_file(control,'p1',k,err_arg) if(err_status) then p_temp_file = k if(.not. temp_file.modify) goto 75 c temp_file.data.nb_data = temp_file.data.nb_sav call dix_util_copy(temp_file.data.nb_data,temp_file.data.data_sav, 1 temp_file.data.data_rec) call dix_message(control,dix_msg_datarest, 1 %val(file.data.nb_data),%descr('UNDO_AREA')) call dix_des_inv_des(control,temp_file) endif c elseif(verb .eq. 'NEXT') then c c NEXT c SYNTAX : Next record goto next record c Next file goto next file c Next description goto next description of this file c call cli$get_Value('p1',line) if(line(1:1) .eq. 'D') then c c NExt description c if(%loc(file) .eq. 0) goto 71 if(file.top_des .eq. 0) goto 72 p_des_expanded = file.cur_des p_des_expanded = des_expanded.link.forw if(p_des_expanded .eq. 0) p_des_expanded = file.top_des file.cur_des = p_des_expanded elseif(line(1:1) .eq. 'F') then c c Next file c if(control.n_file .eq. 0) goto 71 if(control.cur_file .eq. 0) then control.cur_file = control.top_file else control.cur_file = file.link.forw if(control.cur_file .eq. 0) control.cur_file = control.top_file endif else c c Next record c call dix_dump_get_err_lab(control,file_level) call dix_dump_get_eof_lab(control,file_level) err_status = dix_dump_inter_get_file(control,'p2',k,err_arg) if(err_status) then p_temp_file = k err_status = dix_rms_get(control,temp_file) endif end if elseif(verb .eq. 'PREV') then c c PREVIOUS c SYNTAX : PREVIOUS record goto next record c PREVIOUS file goto next file c PREVIOUS description goto next description of this file c call cli$get_Value('p1',line) if(line(1:1) .EQ. 'D') then c c Prev description c if(%loc(file) .eq. 0) goto 71 if(file.top_des .eq. 0) goto 72 p_des_expanded = file.cur_des p_des_expanded = des_expanded.link.backw c c Back to the last description c if(p_des_expanded .eq. 0) then p_des_expanded = file.top_des do while(des_expanded.link.forw .ne. 0) p_des_expanded = des_expanded.link.forw end do end if file.cur_des = p_des_expanded elseif(line(1:1) .EQ. 'F') then c c Prev file c if(control.n_file .eq. 0) goto 71 if(p_file .ne. 0) p_file = file.link.backw if(p_file .eq. 0) then p_file = control.top_file do while(file.link.forw .ne. 0) p_file = file.link.forw end do endif control.cur_file = p_file else c c Take the default, prev record c call dix_dump_get_err_lab(control,file_level) err_status = dix_dump_inter_get_file(control,'p2',k,err_arg) if(err_status) then p_temp_file = k if(temp_file.block_size .ne. 0) then err_status = dix_main_get_rec_int(control, 1 temp_file,temp_file.rec_nr-1) else if(temp_file.indexed) then err_status = dix_rms_read_prev_rec_idx(control, 1 temp_file) elseif(temp_file.relative) then err_status = dix_rms_read_prev_rec_rel(control, 1 temp_file) else err_status = dix_main_get_rec_int(control, 1 temp_file,temp_file.rec_nr-1) end if end if end if end if c elseif(verb .eq. 'SELE') then c c SELECT c Syntax : SELECT FILE Select a file from the list c SELECT DESCRIPTION Select a description from the list c call cli$get_Value('p1',line) if(line(1:1) .eq. 'F') then nk = 0 call cli$get_value('p2',line,nk) if(nk .eq. 0) call sys$fao('*',nk,line) err_status = dix_dump_inter_sel_file(control, 1 dis.is_term,line(1:nk),err_arg) elseif(line(1:1) .eq. 'D') then nk = 0 call cli$get_Value('p2',line,nk) if(%loc(file) .eq. 0) goto 71 if(file.top_des .eq. 0) goto 72 c c Make sure not empty c if(nk .eq. 0) call sys$fao('*',nk,line) c err_status = dix_dump_i_sel_des(control,file, 1 dis.is_term,line(1:nk),err_arg) endif c elseif(verb .eq. 'SEAR') then c c SEAR c Syntax SEAR searchstring... [/rewind][/quiet] c search a record that contains the specified data c if(%loc(file) .eq. 0) goto 71 err_status = dix_search_set_flags(control,1,8) if(err_Status) then control.rewind = cli$present('rewind') signal = cli$present('quiet') call dix_search_stats_init(control) call dix_main_check_mod_record(control,file) c err_status = dix_search_search_file(control,file, 1 signal,max_rfas,rfas,n_rfas,.false.) if(err_status) then err_status = dix_dump_get_rfa(control,file,rfas(2)) endif call dix_search_stats_show(control) endif else goto 70 end if c c All verbs done, try for the next command c if(iterm .eq. 0) goto 10 !Exit terminator c c All others return c goto 90 !return to caller c c Invalid command c 70 err_arg = totline(1:nk_tot) err_status = %loc(dix_msg_illcomm) goto 10 c c Command that needed a file open c and currently no file open gets here c 71 err_status = %loc(dix_msg_nofilopen) goto 10 c c Command that need a descriptor and no one is present c goto here c 72 err_status = %loc(dix_msg_nodescr) goto 10 c c Command that can only be executed in a command file c 73 err_arg = verb err_status = %loc(dix_msg_notonterm) goto 10 c c We are not in modify mode c 75 err_status = %loc(dix_msg_notinmod) goto 10 c c Here if we run into a ENDx and no structure open c this can only happen with goto/gosub c 76 err_status = %loc(dix_msg_illends) err_arg = verb goto 10 c c Here if we run into an ENDx and the open structure c is not the expected one c this can only happen with goto/gosub c 77 err_status = %loc(dix_msg_illends1) err_arg = struct_level.ptrs.begin_verb//' '//verb goto 10 c 90 istat = 1 call dix_eval_free_value(val) call dix_eval_free_value(val1) dix_dump_interactive = istat return end function dix_dump_i_sel_des(control,file,is_term,mask,err_arg) implicit none c c Display a directory of descriptions c And let the user select one (in interactive mode) c include 'dix_interactive.inc' record /control/ control !:i: control structure record /file_info/ file !:i: current file logical*4 is_term !:i: are we on a terminal character*(*) mask !:i: desciptor mask to select character*(*) err_arg !:o: error argument integer*4 dix_dump_i_sel_des !:f: functionresult c# record /des_info/ des_info pointer (p_des_info,des_info) c record /des_expanded/ des_expanded pointer (p_des_expanded, des_expanded) c character*(max_line_length) line,tline character kar integer*4 k,nam_width,nk,i_des,max_width,istat,save_ptr,ptr_desc integer*4 n_fnd,tag_width c logical*4 dix_util_get_nr integer*4 dix_dump_print_line integer*4 dix_dump_inter_next_descr c external dix_msg_desnotm c istat = 1 c c First see how many match c first get the max length of the tag and count them c save_ptr = 0 c ptr_desc = -1 n_fnd = 0 tag_width = 0 c do while(dix_dump_inter_next_descr(file,ptr_desc,mask, 1 wildcard_flag_standard,.false.)) c p_des_expanded = ptr_desc c c Format the long way c tag_width = max(des_expanded.nk_handle,tag_width) n_fnd = n_fnd + 1 save_ptr = ptr_desc end do c c Pick the special cases c 0 : notfound c 1 : Unique match, use it c if(n_fnd .eq. 0) then istat = %loc(dix_msg_desnotm) err_arg = mask goto 90 elseif(n_fnd .eq. 1) then file.cur_des = save_ptr goto 90 endif c c Now we know the width needed for the tag c the line printed is c *nnnn:tag name ssssss c so the remaining size is width-6-tagwidth-1-1-6 c max_width = control.ncols - 6 - tag_width - 8 nam_width = 0 c ptr_desc = -1 do while(dix_dump_inter_next_descr(file,ptr_desc,mask, 1 wildcard_flag_standard,.false.)) c p_des_expanded = ptr_desc c c Format the long way c p_des_info = des_Expanded.p_des_info call dix_des_display_width(control,des_info,line,nk,max_width) nam_width = max(nk,nam_width) end do c c We have more than 1 match, display them c Print header c call sys$fao(' Indx:!#AS !#AS Size',nk,tline, 1 %val(tag_width),%descr('Tag'), 1 %val(nam_width),%descr('Name')) if(.not. dix_dump_print_line(control,0,tline(1:nk))) goto 90 c k = 0 i_des = 0 ptr_desc = -1 do while(dix_dump_inter_next_descr(file,ptr_desc,mask, 1 wildcard_flag_standard,.false.)) p_des_expanded = ptr_desc p_des_info = des_expanded.p_des_info kar = ' ' k = k + 1 if(p_des_expanded .eq. file.cur_des) then i_des = k kar = '*' endif call dix_des_display_width(control,des_info,line,nk,max_width) c call sys$fao('!AS!4UL:!AS !AS !6UL',nk,tline, 1 kar,%val(k), 1 des_expanded.handle(1:tag_width), 1 line(1:nam_width), 1 %val(des_info.table_nor.count + 1 des_info.table_vfc.count)) if(.not. dix_dump_print_line(control,0,tline(1:nk))) goto 90 end do c c Check if at at a terminal, if not exit now c if(is_term) then if(dix_util_get_nr(k,i_des)) then ptr_desc = -1 do k=1,i_des call dix_dump_inter_next_descr(file,ptr_desc,mask, 1 wildcard_flag_standard,.false.) end do file.cur_des = ptr_desc endif endif 90 dix_dump_i_sel_des = istat return end subroutine dix_dump_i_print_des(control,des_info) implicit none c c Print out description record from file/library c include 'dix_interactive.inc' record /control/ control !:io: control structure record /des_info/ des_info !i: des_info block c# character*(max_line_length) line integer*4 lun,nk logical*4 dix_dump_print_line integer*4 dix_lbr_get_module integer*4 memtab_read c include '($lbrdef)' c external dix_msg_libfnop external dix_msg_modnotf external dix_msg_desnopnd c c View original source c if(des_info.in_library .ne. des_in_file) then c c From library c if(dix_lbr_get_module(control,des_info.fnam(1:des_info.nk_fnam), 1 lun,nk,des_info.in_library)) then do while(memtab_read(lun,nk,line)) if(.not. dix_dump_print_line(control,0,line(1:nk))) goto 8 end do 8 call memtab_close(control,lun) else call dix_message(control,dix_msg_modnotf, 1 des_info.fnam(1:des_info.nk_fnam)) endif else c c From file c call lib$get_lun(lun) open(lun,file=des_info.fnam(1:des_info.nk_fnam), 1 shared,readonly,err=88,status='old') 10 read(lun,'(q,a)',end=80) nk,line if(dix_dump_print_line(control,0,line(1:nk))) goto 10 80 close(lun) goto 89 88 call dix_message(control,dix_msg_desnopnd) 89 call lib$free_lun(lun) endif c 90 return end function dix_inter_unsymbol_verb(control,line,nk) implicit none c c Unsymbol a verb c include 'dix_interactive.inc' c record /control/ control !:io: the control block character*(*) line !:io: the line integer*4 nk !:io: length of the line integer*4 dix_inter_unsymbol_verb !:f: function result c# record /value/ val c integer*4 k,istat c character*(max_symbol_name_length) symbol c character*(max_line_length) tline integer*4 nkt,nk_s,ipos integer*4 str$find_first_in_set integer*4 dix_symbol_find c call dix_eval_init_value(val) c if((control.inter_control .and. substitute_verb) .eq. 0) then tline(1:3) = 'not' nkt = 3 else nkt = 0 endif call dix_main_print_debug(control,debug_command, 1 tline(1:nkt)//' Unsymbolize verb |'//line(1:nk)//'|') c if((control.inter_control .and. substitute_verb) .ne. 0) then c c Need verb translation c ipos = str$find_first_in_set(line(1:nk),' /') if(ipos .ne. 0) then c c We have a space or a /. This is a verb, and might be c unsymbolled. try to find the symbol c nk_s = ipos-1 call str$upcase(symbol,line(1:nk_s)) c c Symbols may have the * inside, if it is present (not yet) c istat = dix_symbol_find(control,symbol(1:nk_s),val) if(istat) then c c Yes we have a symbol, insert it c call dix_con_value_intasc(control,val,tline,nkt, 1 des_flag_translate_nor) c call dix_main_print_debug(control,debug_command, 1 'replaced verb '//line(1:ipos-1)// 1 ' with '//tline(1:nkt)) if(line(ipos:ipos) .eq. '/') then c c Separator was a / c line = tline(1:nkt)//line(ipos:nk) nk = nkt + nk - ipos+1 else c c Separator was a space, skip all but one c do k=ipos,nk if(line(k:k) .ne. ' ') goto 12 end do k = nk + 1 12 line = tline(1:nkt)//line(k-1:nk) nk = nkt + nk - k + 2 endif !/ or space endif !found the symbol endif !found the separator endif !need the verb translation c 60 call dix_main_print_debug(control,debug_command, 1 ' Result Unsymbolize_verb |'//line(1:nk)//'|') istat = 1 90 call dix_eval_free_value(val) dix_inter_unsymbol_verb = istat return end function dix_inter_unsymbol_symb(control,line,nk,err_arg) implicit none c c Unsymbol a line c replace all 'xxx' by its expansion c include 'dix_interactive.inc' c record /control/ control !:io: the control block character*(*) line !:io: the line integer*4 nk !:io: length of the line character*(*) err_arg !:o: error argument integer*4 dix_inter_unsymbol_symb !:f: function result c# record /value/ val c integer*4 k,l,bpos,istat,ival logical in_quote,is_symbol logical dix_eval_expression external dix_msg_overflow external dix_msg_openquot1 c character kar c character*(max_line_length) tline integer*4 nkt logical*4 dix_eval_tryradix c call dix_eval_init_value(val) c c See if we need symbol substitution c if((control.inter_control .and. substitute_verb) .eq. 0) then tline(1:3) = 'not' nkt = 3 else nkt = 0 endif call dix_main_print_debug(control,debug_command, 1 tline(1:nkt)//' Unsymbolize symbols |'//line(1:nk)//'|') c if((control.inter_control .and. substitute_symbols) .eq. 0) goto 60 c c We need symbol substitution c in_quote = .false. k = 1 do while(k .le. nk) c c Go find a ' ' pair c if(line(k:k) .eq. '"') in_quote = .not. in_quote c c If we find the !, we can stop c if(line(k:k) .eq. '!' .and. .not. in_quote) goto 60 c if(line(k:k) .eq. '''') then bpos = k if(in_quote) then if(k .eq. nk) then istat = %loc(dix_msg_openquot1) goto 90 endif k = k + 1 if(line(k:k) .ne. '''') goto 20 endif c c We have a leading quote, now search for trailing one c l = k + 1 do while (l .le. nk) if(line(l:l) .eq. '''') then c c Got trailing quote, see if between is symbol c we have one more option c 'dddd'R radix. c Try if next letter//symbolname is a valid number c call str$upcase(tline,line(k+1:l-1)) nkt = l-1 - k call str$upcase(kar,line(l+1:l+1)) if(dix_eval_tryradix(kar//tline(1:nkt),val, 1 control.integer_size)) then c c Yes the 'ddd'R is a radix notation, leave the text in place c if the command expected a number here, it will be evalled again c if this should not be a number, someone will protest later c k = l+1 goto 20 else istat = dix_eval_expression(control,tline(1:nkt),val, 1 .false.,err_arg,.false.,is_symbol) if(.not. istat) goto 90 endif c c Make ascii, and replace in line c call dix_con_value_intasc(control,val,tline,nkt, 1 des_flag_translate_nor) ival = nk + nkt - (l-bpos+1) if(ival .gt. len(line)) then istat = %loc(dix_msg_overflow) err_arg = line(k+1:l-1) goto 90 endif line = line(1:bpos-1)//tline(1:nkt)//line(l+1:nk) nk = nk + nkt - (l-bpos+1) c c Goon after substitution c k = bpos-1 + nkt goto 20 endif l = l + 1 end do c c No trailing quote found, skip c goto 90 endif 20 k = k+ 1 end do 60 call dix_main_print_debug(control,debug_command, 1 ' Result Unsymbolize symbols |'//line(1:nk)//'|') istat = 1 90 call dix_eval_free_value(val) dix_inter_unsymbol_symb = istat return end subroutine unspace(ascdat,nk_data) implicit none c c Remove all double spaces by one space (Except in " " string) c character*(*) ascdat !:io: the text string integer*4 nk_data !:io: length of the line c# logical in_quote integer*4 k,n_out c n_out = 0 in_quote = .false. do k=1,nk_data if(ascdat(k:k) .eq. '"') then in_quote = .not. in_quote else if(.not. in_quote) then if(ascdat(k:k) .eq. ' ') goto 10 endif endif n_out = n_out + 1 ascdat(n_out:n_out) = ascdat(k:k) 10 end do nk_data = n_out return end subroutine dix_dump_show_symbols(control,pattern,hex,all,full) implicit none c c Show all symbols c include 'dix_interactive.inc' c record /control/ control !:io: the control structure character*(*) pattern !:i: the string pattern logical*4 hex !:i: display in hex ? logical all !dispay all symbols (specials too) logical full !:i: display all info of symbol c# character*(max_str_len) tline integer*4 nk,nk_pat,context,level,nkw,nk_ast logical*4 fixed record /value/ value logical dix_dump_print_line c logical str$match_wild logical dix_symbol_enumerate c integer*4 ptr c call dix_eval_init_value(value) nk_pat = len(pattern) c c Go through all symbols c context = 0 do while(dix_symbol_enumerate(control,value,tline,nk, 1 context,all,level,ptr,full,nk_ast,fixed)) c c tline(1:nk_ast) is the required part c if(nk_pat .eq. 0 .or. str$match_wild( 1 tline(1:nk),pattern)) then c c Pattern matches, insert the asterix (if wanted) c if(nk_ast .ne. nk) then tline = tline(1:nk_ast)//'*'//tline(nk_ast+1:nk) nk = nk + 1 endif c if(full) then call dix_append(nk,tline,'(') if(fixed) call dix_append(nk,tline,'Fixed-') call dix_symbol_type(value,tline(nk+1:),nkw,.true.,.false.) nk = nk + nkw call dix_append(nk,tline,',Level=') call dix_symbol_levelasc(level,tline(nk+1:),nkw) nk = nk + nkw call dix_append(nk,tline,')') endif call dix_append(nk,tline,'=') c c Ans the value c if(value.type .eq. symb_typ_char) call dix_append(nk,tline,'"') call dix_con_value_intasc(control,value,tline(nk+1:),nkw,hex) nk = nk + nkw if(value.type .eq. symb_typ_char) call dix_append(nk,tline,'"') if(.not. dix_dump_print_line(control,0,tline(1:nk))) goto 90 endif end do 90 call dix_eval_free_value(value) return end subroutine set_message(control) implicit none c c Set message flags c include 'dix_interactive.inc' record /control/ control !:io: control structure c# integer*4 k,istat c include '($climsgdef)' c logical cli$present c k = control.msgmask if(cli$present('all')) k= 15 if(cli$present('none')) k= 0 istat = cli$present('text') if(istat .eq. cli$_present) k = k .or. 1 if(istat .eq. cli$_negated) k = k .and. 14 c istat = cli$present('ident') if(istat .eq. cli$_present) k = k .or. 2 if(istat .eq. cli$_negated) k = k .and. 13 c istat = cli$present('severity') if(istat .eq. cli$_present) k = k .or. 4 if(istat .eq. cli$_negated) k = k .and. 11 c istat = cli$present('facility') if(istat .eq. cli$_present) k = k .or. 8 if(istat .eq. cli$_negated) k = k .and. 7 c control.msgmask = k return end c subroutine dix_inter_conv_msg(msgmask,line,nk) implicit none c c Convert message flags to ascii c integer*4 msgmask !:i: the message flags character*(*) line !:o: the text integer*4 nk !:o: length of line c# nk = 0 if(msgmask .eq. 15 .or. msgmask .eq. 0) then line = '/ALL' nk = 4 else nk = 0 if(btest(msgmask,0)) call dix_append(nk,line,'/TEXT') if(btest(msgmask,1)) call dix_append(nk,line,'/IDENT') if(btest(msgmask,2)) call dix_append(nk,line,'/SEVERITY') if(btest(msgmask,3)) call dix_append(nk,line,'/FACILITY') endif return end function dix_inter_read_line(control,totline,nk_tot, 1 quiet,ptrs,line_level,err_arg) implicit none c c Read one complete line c return 0 for eof c lower bit set for all oke c lower bit clear for error c include 'dix_interactive.inc' record /control/ control !:i: control structure integer*4 nk_tot !:o: line length character*(*) totline !:o: line read logical quiet !:i: quiet on endwhile/.. search record /struct_pointers/ ptrs !:o: info for loop constructs integer*4 line_level !:o: the line level character*(*) err_arg !:o: error argument logical dix_inter_read_line !:f: errstatus c# record /file_level/ file_level pointer (p_file_level,file_level) c character*(max_line_length) line character*(max_short_line_length) prompt,nrasc integer*4 nk,nk_pr,istat,pos,nk_nrasc,flag,flag1 logical cont_line c include '($smgdef)' include '($tt2def)' c integer*4 smg$read_composed_line integer*4 memtab_read integer*4 memtab_read_level logical dix_util_remove_comment external dix_msg_openquote integer*4 dix_inter_recall integer*4 dix_inter_unsymbol_symb c p_file_level = control.cur_level 5 nk_tot = 0 c cont_line = .false. 10 if(file_level.is_term) then c c Terminal input, let SMG do it (recall buffer enabled) c nk_pr = control.nk_prompt prompt= control.prompt(1:nk_pr) if(control.depth .eq. 1) then nk_nrasc = 0 else call sys$fao('_!UL',nk_nrasc,nrasc,%val(control.depth-1)) endif c c if we find a #, replace if by the nrasc part c pos = index(prompt,'#') if(pos .gt. 0) then prompt = prompt(1:pos-1)//nrasc(1:nk_nrasc)//prompt(pos+1:nk_pr) nk_pr = nk_pr + nk_nrasc - 1 endif c if(cont_line) then prompt = '_'//prompt nk_pr = nk_pr + 1 endif line_level = 0 control.control_c_seen = .false. if(nk_pr .eq. 0) then call sys$fao('>',nk_pr,prompt) endif nk = 0 21 flag = 0 if((control.input_flags .and. input_flag_editing) .eq.0) then flag = smg$m_func_keys endif c c Set the insert flag depening on the what the user wants c if((control.input_flags .and. input_flag_insert) .ne. 0) then c c Set the bit c call smg$set_term_characteristics(control.paste_id, 1 ,tt2$m_insert,,,,flag1) else c c Clear the bit c call smg$set_term_characteristics(control.paste_id, 1 ,,,tt2$m_insert,,flag1) endif c istat = smg$read_composed_line(file_level.lun, 1 control.keytable_id,line, 1 prompt(1:nk_pr),nk,, 1 flag,line(1:nk)) c c Restore the old value c if((flag1 .and. tt2$m_insert) .ne. 0) then c c Set the bit c call smg$set_term_characteristics(control.paste_id,,tt2$m_insert) else c c Clear the bit c call smg$set_term_characteristics(control.paste_id,,,,tt2$m_insert) endif if(.not. istat) goto 80 !return eof istat = dix_inter_recall(control,file_level.lun,line,nk) if(.not. istat) goto 21 istat = dix_inter_unsymbol_symb(control,line,nk,err_arg) c else !is_term c c Read a line from the file, let memtab handle it c it this case , check for control_c to abort c if(cont_line) then istat = memtab_read(file_level.lun,nk,line) pos = 0 else istat = memtab_read_level(file_level.lun, 1 nk,line,line_level,pos, 1 sizeof(ptrs),ptrs) endif if(istat) then c istat = dix_inter_unsymbol_symb(control,line,nk,err_arg) if(.not. istat) goto 40 c c Read from memtab oke c if(.not. quiet) then c c Verify mode, print line c if(file_level.verify) 1 call dix_dump_print_line(control,0,line(1:nk)) endif if(pos .gt. 0) then c c Remove label c line = line(pos:) nk = nk - pos + 1 endif else c c Read from memtab not oke c goto 80 endif !if istat endif !is_term c c Now see if need to append to totline c 40 if(istat) then c c Find the first and the last significant (non-blank) char c if(.not. dix_util_remove_comment(nk,line)) then istat = %loc(dix_msg_openquote) goto 90 endif c c See if line is a continuation line (- at the end) c totline(nk_tot+1:) = line(1:nk) nk_tot = nk_tot + nk if(totline(nk_tot:nk_tot) .eq. '-') then nk_tot = nk_tot - 1 cont_line = .true. goto 10 endif endif c c we have the total line present. see if it is a symbol assignment c goto 90 c c Eof reached c 80 istat = 0 c 90 dix_inter_read_line = istat return end function dix_inter_get_label(line,label,pos) implicit none c c See if the first part of the line contains a label c if so return the text, set pos to just beyond this label c character*(*) line !:i: the line character*(*) label !:o: the label integer*4 pos !:o: pos ion line just beyond the label : logical dix_inter_get_label !:f: true if label found c# integer*4 nk,ipos character kar logical dix_util_legal_char c c label = ' ' pos = 0 c c Now skip all letters/digits c dix_inter_get_label = .false. nk = len(line) ipos = 1 do while(ipos .le. nk) kar = line(ipos:ipos) if(dix_util_legal_char(kar,ipos)) then ipos = ipos + 1 else c c No longer a legal char, now if it is a : then we have a label c if(kar .eq. ':') then dix_inter_get_label = .true. c c Got label, now skip it c call str$upcase(label,line(1:ipos-1)) pos = ipos + 1 !set pointer to just beyond the : endif ipos = nk + 1 !to stop the do loop endif end do return end c subroutine dix_inter_signal(control,err_status,err_arg, 1 line,nk,on_command,file_level,from_read) implicit none c c Signal error messages, and handle on_x and /err= and /end= c include 'dix_interactive.inc' record /control/ control !:io: control structure integer*4 err_status !:i: error status character*(*) err_arg !:io: err argument character*(*) line !:o: returned line (if on_? found) integer*4 nk !:o: length of line logical on_command !:i: on_command ? record /file_level/ file_level !:i: current file info logical from_read !:i: did the error come from a read? c# include '($stsdef)' include '($rmsdef)' c integer*4 err_sev,nk_arg c integer*4 dix_util_get_len_fu external dix_msg_ctrlcseen c if(control.control_c_seen) then call dix_message(control,dix_msg_ctrlcseen) err_status = %loc(dix_msg_ctrlcseen) control.control_c_seen = .false. endif c c Define the symbols $STATUS , $SEVERITY c err_sev = iand(err_status,sts$m_severity) if(.not. on_command) then call dix_symbol_add_int(control,'$STATUS',err_status,err_arg) call dix_symbol_add_int(control,'$SEVERITY',err_sev,err_arg) endif c nk = 0 c if(err_status .eq. %loc(dix_msg_ctrlcseen)) then if(.not. file_level.is_term) then nk = file_level.on_control_c_line.dsc$w_maxstrlen if(nk .gt. 0) then call dix_util_copy_string(file_level.on_control_c_line,line) else call sys$fao('EXIT !UL',nk,line,%val(err_status)) endif goto 90 endif endif c if(.not. err_status) then c c Check for error_label or eof_label c if present, use it c if(.not. file_level.is_term) then if(err_status .eq. rms$_eof) then if(control.eof_label .ne. ' ') then line = 'GOTO '//control.eof_label nk = dix_util_get_len_fu(line) on_command = .true. goto 90 end if endif if(control.error_label .ne. ' ') then line = 'GOTO '//control.error_label nk = dix_util_get_len_fu(line) on_command = .true. goto 90 end if endif !is_term c c If from_read is true, the eror is from a real command c if from_read is false, the error is created here on a higher level c so the message must not be repeated here c Now translate to text and allow the (optional) parameter to c be included. c if the sts$m_inhib_msg is set, do not print the message c if(from_read .and. (err_status .and. sts$m_inhib_msg) .eq. 0) then nk_arg = dix_util_get_len_fu(err_arg) call dix_message(control,%val(err_status),err_arg(1:nk_arg)) endif c c Check on serverity (severe, error or warning) c if(.not. file_level.is_term) then c c Not in terminal mode (we are using a file) c check if set on is active c if(file_level.on_mode) then c c Yes , now see if err_sev >= on_level c on_command = .true. if(err_sev .ge. file_level.on_level) then c c Yes, now return the line, and free it c nk = file_level.on_line.dsc$w_maxstrlen call dix_util_copy_string(file_level.on_line,line) call dix_util_free_descr(file_level.on_line) if(nk .eq. 0 .and. err_sev .gt. sts$k_warning) then c c Not found, return exit (if not warning) c nk = 0 call sys$fao('EXIT !UL',nk,line,%val(err_status)) endif !default error action "exit status" endif !status >= level endif !on mode active endif !processing a terminal endif !err_status c c Exit, clear all error info c 90 err_arg = ' ' err_status = 1 control.error_label = ' ' control.eof_label = ' ' return end function dix_dump_i_show_des(control,file,des_info_i) implicit none c c Show some descriptions c include 'dix_interactive.inc' record /control/ control !:i: cntrol block record /file_info/ file !:i: file block record /des_info/ des_info_i !:i: descroption block integer*4 dix_dump_i_show_des !:f: function result c# c Three options c show des display current description c show des/file show all descriptions of this file c show des/loaded show all descriptions loaded (possible in other files) c show des/all show all descriptions in the library c On all commands you can have c /full Show the contents c /source Show the descriptions from the source c integer*4 istat,lun_memtab,nk,lun,where,nk_mask,nk_wh character*(max_line_length) line,mask logical full,source character*(max_line_length) whasc c integer*4 memtab_read integer*4 dix_dump_print_line integer*4 dix_dump_i_show_des_1 logical dix_lbr_get_list logical dix_lbr_get_module c external dix_msg_nodescr external dix_msg_nolibopen external dix_msg_modnotf external dix_msg_nofilopen logical cli$present 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 full = cli$present('full') source = cli$present('source') if(source) full = .true. c istat = %loc(dix_msg_nofilopen) if(cli$present('file')) then c c Show the descriptions connected to the file c if(%loc(file) .eq. 0) goto 90 if(file.top_des .eq. 0) goto 72 p_des_expanded = file.top_des istat = 1 do while(istat .and. p_des_expanded .ne. 0) istat = dix_dump_i_show_des_1(control, 1 %val(des_expanded.p_des_info),full,source,.false.) p_des_expanded = des_expanded.link.forw end do elseif(cli$present('loaded')) then c c Show all loaded descriptions (for all files) c if(control.top_descr .eq. 0) goto 72 p_des_info = control.top_descr istat = 1 do while(istat .and. p_des_info .ne. 0) istat = dix_dump_i_show_des_1(control,des_info,full,source,.true.) p_des_info = des_info.link.forw end do elseif(cli$present('all')) then c c Show the defined descriptions for the libraries c if(control.nk_syslib .eq. 0 .and. control.nk_userlib .eq. 0) then istat = %loc(dix_msg_nolibopen) else call cli$get_value('p2',mask,nk_mask) if(nk_mask .eq. 0) then mask = '*.*' nk_mask = 3 endif where = des_in_userlib whasc = 'USER-library = '// 1 control.userlib_name(1:control.nk_userlib) nk_wh = 15 + control.nk_userlib 10 if(dix_lbr_get_list(control,lun_memtab,mask(1:nk_mask), 1 where,.true.)) then istat = dix_dump_print_line(control,0,'Contents of '// 1 whasc(1:nk_wh)) call memtab_rewind(lun_memtab) do while(istat .and. memtab_read(lun_memtab,nk,line)) istat = dix_dump_print_line(control,2,line(1:nk)) if(full) then if(dix_lbr_get_module(control,line(1:nk),lun,nk,where)) then do while(istat .and. memtab_read(lun,nk,line)) istat = dix_dump_print_line(control,0,line(1:nk)) end do call memtab_close(control,lun) else call dix_message(control,dix_msg_modnotf,line(1:nk)) endif endif end do call memtab_close(control,lun_memtab) endif if(where .eq. des_in_userlib) then where = des_in_syslib whasc = 'SYSTEM-library = '// 1 control.syslib_name(1:control.nk_syslib) nk_wh = 15 + control.nk_syslib goto 10 endif endif else c c View current description c if(%loc(file) .eq. 0) goto 90 if(file.top_des .eq. 0) then istat = %loc(dix_msg_nodescr) else istat = dix_dump_i_show_des_1(control,des_info_i, 1 full,source,.false.) endif endif goto 90 72 istat = %loc(dix_msg_nodescr) 90 dix_dump_i_show_des = istat return end function dix_dump_i_show_des_1(control,des_info,full,source,usage) implicit none c c Show current desciption c include 'dix_interactive.inc' record /control/ control !:io: control structure record /des_info/ des_info !:i: des info logical full !:i: full display logical source !:i: from the source? logical usage !:i: useage count too? integer*4 dix_dump_i_show_des_1 c# character*(max_line_length) line c record /file_info/ file pointer (p_file,file) record /des_expanded/ des_expanded pointer (p_des_expanded,des_expanded) c integer*4 istat,nk integer*4 dix_dump_print_line c c Get module name c call dix_des_display(control,des_info,line,nk,.false.) istat = dix_dump_print_line(control,0,'Description : '//line(1:nk)) if(.not. istat) goto 90 c c if(full) then c nk = 0 if(des_info.fixed) call dix_append(nk,line,'Fixed,') if(des_info.has_fields) call dix_append(nk,line,'Contains fields,') if(nk .gt. 0) then istat = dix_dump_print_line(control,0,'Status : '//line(1:nk-1)) if(.not. istat) goto 90 endif c if(usage) then c c Return a list of files using this description c istat = dix_dump_print_line(control,0, 1 'Description is used by the following files:') p_file = control.top_file do while(p_file .ne. 0) p_des_expanded = file.top_des do while(p_des_expanded .ne. 0) if(des_expanded.p_des_info .eq. %loc(des_info)) then istat = dix_dump_print_line(control,2, 1 file.fnam(1:file.nk_fnam)) goto 10 endif p_des_expanded = des_expanded.link.forw end do 10 p_file = file.link.forw end do endif if(source) then c c View description from source file/module c call dix_dump_i_print_des(control,des_info) else c c View description/parameters from internal data c call dix_dump_print_par(control, 1 des_info.parameters.count, 1 %val(des_info.parameters.address),'*',.false.) call dix_dump_print_line_int(control, 1 des_info.table_nor.count, 1 %val(des_info.table_nor.address), 1 des_info.first_nor_var) call dix_dump_print_line_int(control, 1 des_info.table_vfc.count, 1 %val(des_info.table_vfc.address), 1 des_info.first_vfc_var) endif end if 90 dix_dump_i_show_des_1 = istat return end subroutine dix_dump_i_set_paged(paged,is_term) implicit none c c Set paged mode c logical paged !:o: paged mode? logical is_term !:i: are we on a terminal c# integer*4 istat c integer cli$present include '($climsgdef)' c if(is_term) then istat = cli$present('PAGED') if(istat .eq. cli$_present) paged = 1 if(istat .eq. cli$_negated) paged = 0 if(cli$present('screen')) paged = 3 else paged = .false. endif return end function dix_dump_i_open_output(control,save_lun,save_paged,err_arg, 1 is_term,file_level) implicit none c c Open a temp output file "/output=xxx" c include 'dix_interactive.inc' record /control/ control !:io: control structure integer*4 save_lun !:o: original lun integer*4 save_paged !:o: save paged mode character*(*) err_arg !:o: error argument logical is_term !:i: are we on terminal record /file_level/ file_level !:io: command file level integer*4 dix_dump_i_open_output!:f: function result c# integer*4 istat,ios character*(max_line_length) line external dix_msg_filnotop c istat = 1 call cli$get_value('output',line) c save_paged = control.paged if(line .eq. ' ') then c c Output to teminal, check for /paged flag c save_lun = 0 ios = 0 call dix_dump_i_set_paged(control.paged,is_term) if(control.paged .eq. 3) 1 call memtab_init(control,control.smg_window, 1 'DIX_INTER_MEM') else c c To file c save_lun = file_level.lun_out control.paged = 0 call lib$get_lun(file_level.lun_out) c c OPen with the max width, but allow a little overhead c open(file_level.lun_out,file=line,status='new', 1 defaultfile='.lis', 1 carriagecontrol='list',iostat=ios, 1 recl=max_command_length) c c Show description(s) c if(ios .ne. 0) then call lib$free_lun(file_level.lun_out) file_level.lun_out = save_lun save_lun = 0 istat = %loc(dix_msg_filnotop) err_arg = line endif endif dix_dump_i_open_output = istat return end subroutine dix_dump_i_close_output(control,save_lun,save_paged, 1 file_level,header) implicit none c c Close temporary output file c include 'dix_interactive.inc' record /control/ control !:io: control structure integer*4 save_lun !:i: saved orig file lun integer*4 save_paged !:io: saved paged mode record /file_level/ file_level !:i: command_file level character*(*) header !:i: the header c# integer*4 nlines c if(control.paged .eq. 3) then call memtab_get_nlines(control.smg_window,nlines) if(nlines .gt. 0) then call smg$erase_pasteboard(control.paste_id) call dix_smg_view_memtab(control,control.smg_window, 1 header,22,.false.) endif call memtab_close(control,control.smg_window) control.smg_window = 0 elseif(save_lun .ne. 0) then close (file_level.lun_out) call lib$free_lun(file_level.lun_out) file_level.lun_out = save_lun save_lun = 0 endif control.paged = save_paged return end c function dix_inter_get_params(control,line, 1 err_arg,is_call) implicit none c c Evaluate line for arguments for @ and CALL c include 'dix_interactive.inc' record /control/ control !:io: the control sturcture character*(*) line !:i: the input line with the expressions character*(*) err_arg !:o: error argument logical is_call !:i: is this a call or an @ integer*4 dix_inter_get_params !:f: the function result c# integer*4 nk,pos,istat,narg record /value/ val character kar c character*(max_symbol_name_length) symbol,name integer*4 nk_symb,nk_name,type logical is_symbol c external dix_msg_toompar external dix_msg_toomuch external dix_msg_mustbesymb external dix_msg_invtype external dix_msg_argcount external dix_msg_wrtypstr external dix_msg_undecl integer*4 dix_eval_expression1 logical cli$get_value logical cli$present logical dix_util_check_name integer*4 dix_symbol_set_alias c call dix_eval_init_value(val) nk = len(line) narg = 0 istat = 1 kar = NULL c do while(nk .gt. 0) c c Now evaluate the part of the line upto the , c First see if the expression ia a symbol, if so c we might alias the new name to this one c c We must decrement level for the evaluation phase, otherwise c symbols cannot be found c control.depth = control.depth-1 istat = dix_eval_expression1(control,line(1:nk),val, 1 .false.,err_arg,.false.,kar,pos,is_symbol) control.depth = control.depth+1 if(.not. istat) goto 90 if(is_symbol) then if(kar .eq. NULL) then nk_symb = pos-1 else nk_symb = pos-2 endif symbol = line(1:nk_symb) endif c c One more argument c narg = narg + 1 c if(is_call) then c c Check if there was an argument name on the subroutine line c call cli$get_value('p1',name,nk_name) C if(nk_name .eq. 0) then c c There are more expressions defined than there are variables c Not allowed in strict mode c if(iand(control.strict_mode,strict_declaration).ne.0) goto 70 endif c type = symb_typ_none if(cli$present('REAL' )) type = symb_typ_real if(cli$present('INTEGER' )) type = symb_typ_int if(cli$present('DATE' )) type = symb_typ_date if(cli$present('DECIMAL' )) type = symb_typ_decimal if(cli$present('LOGICAL' )) type = symb_typ_log if(cli$present('CHARACTER')) type = symb_typ_char if(iand(control.strict_mode,strict_typing) .ne. 0) then c c Strict typing c if(type .eq. symb_typ_none) goto 71 !no type if(type .ne. val.type) goto 72 !wrong type type = val.type !take type of expression endif c c Must be valid symbolname c if(cli$present('symbol')) then c c We want the local var to be an alias of the original expression c this can only be true if the expression consists of a symbol only c if(.not. is_symbol) goto 73 else c c We do not want the alias entered c is_symbol = .false. endif c c Check if name is a valid symbol name c istat = dix_util_check_name(name(1:nk_name)) if(.not. istat) goto 80 !invalid symbol name else c c For @ the parameters are called p'n' c nk_name = 0 endif if(nk_name .eq. 0) then c c No name or illegal name c if(iand(control.strict_mode,strict_declaration).ne.0) goto 70 call sys$fao('P!UL',nk_name,name,%val(narg)) type = symb_typ_none endif c c Define the (local) symbol c call dix_symbol_add_level(control,name(1:nk_name),val,err_arg, 1 type .ne. symb_typ_none,' ') if(is_symbol) then istat = dix_symbol_set_alias(control,symbol(1:nk_symb), 1 name(1:nk_name),err_arg) if(.not. istat) goto 90 endif c c Skip the part upto and including the , c nk = nk - pos + 1 line = line(pos:) end do c c Now ther may not be anything left on the line c if(kar .ne. NULL) then istat = %loc(dix_msg_toomuch) err_arg = kar goto 90 endif c c There are no more expressions. c Now define the $arguments variable c val.ival = narg val.type = symb_typ_int call dix_eval_sign_extend(val) call dix_symbol_add_level(control,'$NRARGS',val,err_arg,.true.,' ') c if(is_call) then c c Check if there are more vars than expressions c do while(cli$get_value('p1',name,nk_name)) if(iand(control.strict_mode,strict_declaration) .ne. 0) goto 70 if(cli$present('symbol')) then c c We want the local var to be an alias of the original expression c this can only be true if the expression consists of a symbol only c and it must exist c goto 73 endif val.type = symb_typ_none if(cli$present('REAL' )) val.type = symb_typ_real if(cli$present('INTEGER' )) val.type = symb_typ_int if(cli$present('DECIMAL' )) val.type = symb_typ_decimal if(cli$present('DATE' )) val.type = symb_typ_date if(cli$present('LOGICAL' )) val.type = symb_typ_log if(cli$present('CHARACTER')) val.type = symb_typ_char if(iand(control.strict_mode,strict_typing) .ne. 0) then if(val.type .eq. symb_typ_none) goto 71 endif call dix_symbol_default(control,val) call dix_symbol_add_level(control,name(1:nk_name),val,err_arg, 1 val.type .ne. symb_typ_none,' ') end do endif err_arg = line(1:nk) goto 90 70 istat = %loc(dix_msg_argcount) goto 80 71 istat = %loc(dix_msg_undecl) goto 80 72 istat = %loc(dix_msg_wrtypstr) goto 80 73 istat = %loc(dix_msg_mustbesymb) 80 err_arg = name(1:nk_name) c 90 call dix_eval_free_value(val) dix_inter_get_params = istat return end subroutine dix_inter_open_struct(control,file_level,ptrs) implicit none c c Open a structure (for/while...etc..) c include 'dix_interactive.inc' record /control/ control !:i: control block record /file_level/ file_level !:io: command file structure record /struct_pointers/ ptrs !:i: the line pointers c# record /struct_level/ struct_level pointer (p_struct_level,struct_level) c c Allocate a new structure c call get_vm(control,sizeof(struct_level),p_struct_level, 1 file_level.zone_level,.false., 1 'STRUCT_LEVEL') struct_level.magic = magic_struct_level struct_level.first = .true. !just created c c We have a new one, now link in c call dix_inter_insert_link(struct_level,file_level.top_struct, 1 file_level.cur_struct,file_level.struct_level) struct_level.ptrs = ptrs return end subroutine dix_inter_close_struct(control,file_level) implicit none c c Close an open structure (for/while etc.) c include 'dix_interactive.inc' record /control/ control !:io: control,structure record /file_level/ file_level !:io: commandfile level c# record /struct_level/ struct_level pointer (p_struct_level,struct_level) c c Delete all symbols for this level c call dix_symbol_delete_level(control) p_struct_level = file_level.cur_struct c c remove it from the chain c call dix_inter_remove_link(file_level.top_struct, 1 file_level.cur_struct,file_level.struct_level) c c Now remove structure c call free_vm(control,sizeof(struct_level),p_struct_level, 1 file_level.zone_level) return end function dix_inter_set_local(control,ascdat,nk, 1 err_arg,def_symbtyp) implicit none c c Declare a local variable c include 'dix_interactive.inc' record /control/ control !:io: control structure character*(*) ascdat !:i: the command line integer*4 nk !:i: Length character*(*) err_arg !:o: the error argument integer*4 def_symbtyp !:i: default symboltype integer*4 dix_inter_set_local !:f: function result c# character*(max_symbol_name_length) symbol record /value/ val character kar integer*4 k,pos,nk_symb,istat,symbtyp,l logical is_symbol c integer*4 dix_util_check_name integer*4 dix_symbol_exists integer*4 dix_eval_expression1 integer*4 dix_util_check_field integer*4 str$find_first_in_set integer*4 dix_symbol_add_level c external dix_msg_toomuch external dix_msg_invstype external dix_msg_symbdef external dix_msg_wrongtype c call dix_eval_init_value(val) do while(nk .gt. 0) c c The string consists of value[,value...] c where value is c either 1.symbol[/type=symboltype]=expression c or 2.symbol[/type=symboltype] c Now find the first occurrence of a /, an = or a , c c k = str$find_first_in_set(ascdat(1:nk),'/=,') if(k .eq. 0) k = nk + 1 nk_symb = k-1 symbol = ascdat(1:nk_symb) c c Check if valid symbol name c istat = dix_util_check_name(symbol(1:nk_symb)) if(.not. istat) then err_arg = symbol(1:nk_symb) goto 90 endif c kar = ascdat(k:k) ascdat = ascdat(k+1:nk) nk = nk - k c c Now parse the type (if present) c symbtyp = def_symbtyp if(kar .eq. '/') then k = str$find_first_in_set(ascdat(1:nk),'=,') if(k .eq. 0) k = nk+1 istat = dix_util_check_field(ascdat(1:k-1), 1 'CHARACTER|INTEGER|REAL|LOGICAL|DATA|DECIMAL',l) if(.not. istat) then istat = %loc(dix_msg_invstype) err_arg = ascdat(1:k-1) goto 90 endif if(ascdat(1:1) .eq. 'C') symbtyp = symb_typ_char if(ascdat(1:1) .eq. 'I') symbtyp = symb_typ_int if(ascdat(1:1) .eq. 'R') symbtyp = symb_typ_real if(ascdat(1:1) .eq. 'L') symbtyp = symb_typ_log if(ascdat(1:2) .eq. 'DA') symbtyp = symb_typ_date if(ascdat(1:2) .eq. 'DE') symbtyp = symb_typ_decimal kar = ascdat(k:k) ascdat = ascdat(k+1:nk) nk = nk - k endif c c Now check for the expression (the kar must be =) c if(kar .eq. '=') then istat = dix_eval_expression1(control,ascdat(1:nk),val, 1 .false.,err_arg,.false.,kar,pos,is_symbol) if(.not. istat) goto 90 if(kar .ne. NULL .and. kar .ne. ',') then istat = %loc(dix_msg_toomuch) err_arg = kar goto 90 endif c if(symbtyp .ne. symb_typ_none) then if(val.type .ne. symbtyp) then istat = %loc(dix_msg_wrongtype) err_arg = symbol(1:nk_symb) goto 90 endif endif ascdat = ascdat(pos:nk) nk = nk - pos + 1 else val.type = symbtyp call dix_symbol_default(control,val) endif c c Now define the new symbol, only if it does not yet exists c if(dix_symbol_exists(control,symbol(1:nk_symb))) then istat = %loc(dix_msg_symbdef) err_arg = symbol(1:nk_symb) else istat = dix_symbol_add_level(control,symbol(1:nk_symb), 1 val,err_arg, 1 symbtyp .ne. symb_typ_none,' ') endif if(.not. istat) goto 90 end do c 90 call dix_eval_free_value(val) dix_inter_set_local = istat nk = 0 return end subroutine dix_inter_show_dis(control,dis) implicit none include 'dix_interactive.inc' c c Display default display params c record /control/ control record /dis_pars/ dis c# character*(max_short_line_length) line character*(max_tf_asc_length) dix_util_tfas c call dix_dump_print_line(control,0,'Default display mode') call dix_dump_print_line(control,0, 1 ' Rawmode : '//dix_util_tfas(dis.raw)) call dix_dump_print_line(control,0, 1 ' How data is displayed(DESCRIPTION)') call dix_dump_print_line(control,0, 1 ' Tagged : '//dix_util_tfas(dis.tag)// 1 ' Fieldnames : '//dix_util_tfas(dis.field)// 1 ' Compressed : '//dix_util_tfas(dis.compres)) c call dix_dump_print_line(control,0, 1 ' How data is displayed(RAW)') line = 'Byte' if(dis.word .eq. 2) line = 'Word' if(dis.word .eq. 4) line = 'Longword' call dix_dump_print_line(control,0, 1 ' Unsigned : '//dix_util_tfas(dis.unsigned)// 1 ' Word size : '//line(1:8)) c call dix_dump_print_line(control,0, 1 ' How data is displayed(BOTH)') line = 'Decimal' if(dis.hex .eq. des_flag_translate_hex) line = 'Hex' if(dis.hex .eq. des_flag_translate_oct) line = 'Octal' if(dis.hex .eq. des_flag_translate_bin) line = 'Binary' call dix_dump_print_line(control,0, 1 ' Data Radix : '//line(1:7)// 1 ' Offset : '//dix_util_tfas(dis.number)// 1 ' Hex Offset : '//dix_util_tfas(dis.number_hex)) c call dix_dump_print_line(control,0, 1 ' What part of the data is displayed') call dix_dump_print_line(control,0, 1 ' Recordsize : '//dix_util_tfas(dis.recsiz)// 1 ' Recordnumber: '//dix_util_tfas(dis.recnr)// 1 ' RFA : '//dix_util_tfas(dis.rfa)) call dix_dump_print_line(control,0, 1 ' Data : '//dix_util_tfas(dis.data)// 1 ' VFCdata : '//dix_util_tfas(dis.vfc)) return end subroutine dix_inter_set_display(dis,all) implicit none include 'dix_interactive.inc' c c Set default display params c record /dis_pars/ dis !:io: display block logical all !:i: ask for the selection qualifiers too? c# logical*4 flag logical*4 cli$present include '($climsgdef)' c call dix_inter_set_hex_mode(dis.hex) if(cli$present('BYTE')) dis.word = 1 if(cli$present('WORD')) dis.word = 2 if(cli$present('LONGWORD')) dis.word = 4 flag = cli$present('NUMBER') if(flag .eq. cli$_negated) then dis.number = .false. dis.number_hex = .false. else if(cli$present('number.decimal')) then dis.number = .true. dis.number_hex = .false. elseif(cli$present('number.hex')) then dis.number = .true. dis.number_hex = .true. else dis.number = .true. endif endif call dix_util_set_flag('RAW',dis.raw) call dix_util_set_flag('COMPRESS',dis.compres) call dix_util_set_flag('COMPRESS',dis.unsigned) call dix_util_set_flag('COMPRESS',dis.tag) call dix_util_set_flag('FIELD',dis.field) call dix_util_set_flag('DATA',dis.data) call dix_util_set_flag('TAG',dis.tag) if(all) then call dix_util_set_flag('VFC',dis.vfc) call dix_util_set_flag('RFA',dis.rfa) call dix_util_set_flag('RECSIZ',dis.recsiz) call dix_util_set_flag('RECNR',dis.recnr) call dix_util_set_flag('data' ,dis.data) else flag = cli$present('display.all') if(flag .eq. cli$_present .or. flag .eq. cli$_negated .or. 1 flag .eq. cli$_defaulted)then dis.data = flag .ne. cli$_negated dis.vfc = flag .ne. cli$_negated dis.recnr = flag .ne. cli$_negated dis.recsiz= flag .ne. cli$_negated dis.rfa = flag .ne. cli$_negated endif call dix_util_set_flag('display.data' ,dis.data) call dix_util_set_flag('display.vfc' ,dis.vfc) call dix_util_set_flag('display.recnr' ,dis.recnr) call dix_util_set_flag('display.recsiz',dis.recsiz) call dix_util_set_flag('display.rfa' ,dis.rfa) endif c return end subroutine dix_inter_massage(totline,nk_tot) implicit none c c Handle some special cases of input c character*(*) totline integer*4 nk_tot c# if(totline(1:1) .eq. '@') then c c Make @ command parsable to AT command c totline = 'AT '//totline(2:nk_tot) nk_tot = nk_tot + 2 endif if(totline(1:3) .eq. 'IF(') then c c Make sure there is a space between the IF and the ( c totline = 'IF '//totline(3:nk_tot) nk_tot = nk_tot + 1 endif if(totline(1:4) .eq. 'END ') then c c Special END case, c useful for END IF instead of ENDIF, END FOR and END WHILE c totline = totline(1:3)//totline(5:nk_tot) nk_tot = nk_tot - 1 endif return end function dix_dump_i_exam(control,dis,verb,err_arg,file_level) implicit none c c Examine some field value(s) c include 'dix_interactive.inc' record /control/ control !:i: control structure record /dis_pars/ dis !:i: the display fields character*(*) verb !:i: the verb exam/sear logical is_exam !:i: search/examine flag character*(*) err_arg !:o: error argument record /file_level/ file_level !:i: the command file integer*4 dix_dump_i_exam !:f: function result 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 character*(max_search_length) search,mask character*(max_line_length) line,intro character*(max_line_length) file_mask,desc_mask character dis_typ integer*4 nk_search,nk_mask,istat,save_lun,save_paged,nk_l,nk integer*4 nk_fm,nk_dm,nk_intro,nk_intro_f integer*4 ptr_file,ptr_desc logical displ_des,mark,wild_flag logical*4 org_raw,got_file,display_all,multiple,something logical*4 do_expand,header record /dis_pars/ dis_work c logical cli$present logical cli$get_value integer*4 dix_dump_i_open_output integer*4 dix_util_get_len_fu integer*4 dix_dump_displ integer*4 dix_dump_inter_next_file integer*4 dix_dump_inter_next_descr c external dix_msg_nofmatch external dix_msg_nofilopen external dix_msg_nofilmat external dix_msg_nodescr c call cli$get_value('search',search,nk_search) c call dix_dump_inter_set_wild(wild_flag,wildcard_flag_none) c c For compatibility reasons check for the /unix qualifier=wildcard.extended c c c Check what the user wants to see c is_exam = verb .eq. 'EXAM' dis_typ = 'R' !record if(cli$present('ORIGINAL' )) dis_typ = 'O' !org record if(cli$present('SAVE_AREA' )) dis_typ = 'S' !save buffer if(cli$present('VFC')) dis_typ = 'V' !VFC buffer c displ_des = cli$present('DESCRIPTION') c header = cli$present('header') c c Set (temporary) display modes c dis_work = dis c c We want the display of the recnr,etc.. only when user explicitly select it c dis_work.recnr = .false. dis_work.recsiz = .false. dis_work.rfa = .false. c c Get the qualifiers c call dix_inter_set_display(dis_work,.false.) c c If we have multiple files/descriptions c and we want .not. raw display c if then one of the descriptins cannot be expanded c that description is dumped raw c but the others will be in description mode c org_raw = dis_work.raw !save it display_all = cli$present('all') c if(control.is_term) then mark = cli$present('MARK') else mark = .false. endif do_expand = cli$present('expand') c nk_mask = 0 nk_fm = 0 nk_dm = 0 c if(is_exam) then c c Examine all fields [filemask\][modmask\]fieldmask c call cli$get_value('p1',mask,nk_mask) call str$upcase(mask(1:nk_mask),mask(1:nk_mask)) c if(dis_typ .ne. 'S') then c c See for file mask, but not for the save area c nk_fm = index(mask(1:nk_mask),'\') if(nk_fm .gt. 0) then c c YEs we have a filemask, extract it c file_mask = mask(1:nk_fm-1) mask = mask(nk_fm+1:nk_mask) nk_mask = nk_mask - nk_fm nk_fm = nk_fm - 1 c c See if we have a module mask c nk_dm = index(mask(1:nk_mask),'\') if(nk_dm .ne. 0) then c c Yes, so extract it c desc_mask = mask(1:nk_dm-1) mask = mask(nk_dm+1:nk_mask) nk_mask = nk_mask - nk_dm nk_dm = nk_dm - 1 endif endif endif line = mask(1:nk_mask) nk_l = nk_mask if(nk_search .gt. 0) then call dix_append(nk_l,line,'/search=') call dix_append(nk_l,line,search(1:nk_search)) endif else c c The parameter is a search string c line = search(1:nk_search) nk_l = nk_search endif c c Open the output file c multiple = (nk_fm .gt. 0) .or. (nk_dm .gt. 0) c istat = dix_dump_i_open_output(control,save_lun,save_paged, 1 err_arg,dis.is_term,file_level) if(.not. istat) goto 90 c something = .false. c c set pointer correctly c For no filemask, take the current file c else take the first file c c Assume no file matches c got_file = .false. c ptr_file = 0 do while(dix_dump_inter_next_file(control,ptr_file, 1 file_mask(1:nk_fm), 1 wildcard_flag_standard)) c nk_intro_f = 0 got_file = .true. p_file = ptr_file c c If we want tagged display, build the info line with the current file tag c if(dis_work.tag) then call dix_append(nk_intro_f,intro,file.handle(1:file.nk_handle)) call dix_append(nk_intro_f,intro,'\') else c c Else, if multiple files wanted, display the filename c if(nk_fm .gt. 0) then call dix_dump_print_line(control,0, 1 'File:'//file.fnam(1:file.nk_fnam)) endif endif c c Now go through all desciptions of this file that match the desc_mask c (or the current if no mask present) c ptr_desc = -1 nk_intro = nk_intro_f do while(dix_dump_inter_next_descr(file,ptr_desc, 1 desc_mask(1:nk_dm),wildcard_flag_standard, 1 .true.)) c p_des_expanded = ptr_desc !can be 0 c if(p_des_expanded .ne. 0) then c c If we want a forced expand, clear the .is_expanded flag c if(do_expand) then des_expanded.is_expanded = .false. 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 endif c c If we want tagged display, append the decription tag to the intro c if(dis_work.tag) then call dix_append(nk_intro,intro, 1 des_expanded.handle(1:des_expanded.nk_handle)) call dix_append(nk_intro,intro,'\') endif c c expand c call dix_des_expand(control,des_expanded,file,.true.) p_des_info = des_expanded.p_des_info endif c c If we do not want the tagged display and the description mak <>' ' c display the description filename c if(.not. dis_work.tag) then if(nk_dm .gt. 0) then call dix_dump_print_line(control,0, 1 'Description:'//des_info.fnam(1:des_info.nk_fnam)) endif endif c c Force raw display for nodescr, of descr expansion error c Reset the .raw to the original setting c and set it if there is some expansion error c dis_work.raw = org_raw if(p_des_expanded .eq. 0) then dis_work.raw = .true. else if(des_expanded.expand_error) dis_work.raw = .true. endif c c Now go display the wanted data c if(dis_typ .eq. 'O' .and. file.modify) then c c The original data (the saved (unchanged) record) c only if file.modify set c otherwise we take the default (the current record) c istat = dix_dump_displ(control, 1 file.data.data_sav,file.data.nb_sav,des_info, 1 des_expanded,dis_work, 1 displ_des, 1 mask(1:nk_mask),search(1:nk_search),'Original record', 1 .false.,file,wild_flag,display_all,err_arg, 1 something,intro(1:nk_intro),header) c elseif(dis_typ .eq. 'S') then c c Display the save area c istat = dix_dump_displ(control, 1 control.save_area,control.nb_save,des_info, 1 des_expanded,dis_work, 1 displ_des, 1 mask(1:nk_mask),search(1:nk_search),'Save Area', 1 .false.,file,wild_flag,display_all,err_Arg, 1 something,intro(1:nk_intro),header) c elseif(dis_typ .eq. 'V') then c c Display the VFC bufer c istat = dix_dump_displ(control, 1 file.data.vfc_data,file.data.nb_vfc,des_info, 1 des_expanded,dis_work, 1 displ_des, 1 mask(1:nk_mask),search(1:nk_search),'VFC Buffer', 1 .false.,file,wild_flag,display_all,err_arg, 1 something,intro(1:nk_intro),header) else c c Display the current record c istat = dix_dump_displ(control, 1 file.data.data_rec,file.data.nb_data,des_info, 1 des_expanded,dis_work, 1 displ_des, 1 mask(1:nk_mask),search(1:nk_search),' ', 1 mark,file,wild_flag,display_all,err_arg, 1 something,intro(1:nk_intro),header) c endif if((.not. istat) .and. multiple) then nk = dix_util_get_len_fu(err_arg) call dix_message(control,%val(istat),err_arg(1:nk)) istat = 1 endif c c Try next description c end do c c Try next file c end do c c All files/descriptions done, c call dix_dump_i_close_output(control,save_lun, 1 save_paged,file_level, 1 verb//' ' //line(1:nk_l)) c if(multiple) then c c For multiple file/des output, only return notfound message c istat = 1 c if(.not. something) then c c No field mask c istat = %loc(dix_msg_nofmatch) err_arg = mask(1:nk_mask) endif c if(.not. got_file) then c c No file mask c err_arg = file_mask(1:nk_fm) if(control.top_file .eq. 0) then istat = %loc(dix_msg_nofilopen) else istat = %loc(dix_msg_nofilmat) endif endif endif c 90 dix_dump_i_exam = istat return end function dix_dump_displ(control,data,nb_data,des_info, 1 des_expanded, 1 dis,displ_des, 1 mask,search,dat_typ,mark,file,wild_flag,display_all, 1 err_arg,something,intro,header) implicit none c c Display the contents of the fields c from 1: Record buffer (Current record) c 2: Paste buffer (Data from the last CUT) c 3: Original buffer (before changes to record) c 4: VFC data For some files with VFC data c include 'dix_interactive.inc' record /control/ control !:i: control structure byte data(*) !:i: the data integer*4 nb_data !:i: #bytes in data record /des_info/ des_info !:i: description record /des_expanded/ des_expanded !:i: description record /dis_pars/ dis !:i: display data logical*4 displ_des !:i: display descriptions too? character*(*) mask !:i: mask for fieldnames character*(*) search !:i: search for fieldvalues character*(*) dat_typ !:i: the databuffer type logical mark !:i: mark keys logical wild_flag !:i: type of search logical display_all !:i: display all data types record /file_info/ file !:i: the file structure character*(*) err_arg !:o: error argument logical*4 something !:o: set to .true. is someting printed character*(*) intro !:i: file\descr\ string logical*4 header !:i: display header line for raw dump? integer*4 dix_dump_displ !:f: function result c# record /des_rec/ des_recs(1) pointer (p_des_recs,des_recs) c integer*4 n_bol integer*4 begpos_bol(10),endpos_bol(10) c integer*4 nk_off,nk_min_1,k,nk1,offs,istat,nkar,max_len,bpos,nk_fol integer*4 kpl,epos,nk,nl,fldsiz,posasc,phase,endpos,pp,nfld_pr,ndes integer*4 end_offs,ipos,old_nl logical*4 set_bold character*(max_line_length) line,field_name character*(max_str_len) ascdat c integer*4 dix_con_i4 integer*4 dix_con_intasc logical*4 dix_util_find_string_wild logical*4 dix_util_match_string_wild logical*4 dix_dump_Print_line logical*4 dix_write_file logical dix_rms_offset_in_key,in_vfc logical display_des,skip c external dix_msg_nomaskoff external dix_msg_nofldfnd external dix_msg_nodata c istat = 1 nl = 0 nfld_pr = 0 in_vfc = dat_typ(1:3) .eq. 'VFC' c c If dat_typ <> ' ' (record data), display which data we print c if(dat_typ .ne. ' ') then call dix_dump_print_line(control,0,'Data from '//dat_typ) endif c c If recordnumber or recordnumber displayed and no mask, all is done? c if(nb_data .eq. 0) then istat = %loc(dix_msg_nodata) goto 90 endif c old_nl = control.linenr c c Start displaying c if(.not. dis.raw) then c c In interpreted mode c call dix_dump_print_header(control,file,dis) nk_off = 0 if(dis.number) then c c Compute the size of the maximum byte offset c call dix_util_con_nr(nb_data*8,des_info.has_fields, 1 line,nk_off,dis.number_hex,control) end if c nk_min_1 = 0 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 do phase=1,2 do k=1,ndes if(control.control_c_seen) goto 90 call str$copy_dx(field_name,des_recs(k).nam) nk1 = des_recs(k).nam.dsc$w_maxstrlen c c See if we do not want to display this field c two reasons c 1. User specified /nodisplay c 2. user wanted compressed data, and this field is "zero" c skip = (des_recs(k).flags .and. des_flag_no_display) .ne. 0 if(.not. skip) then c c Not a nodisplay field, check for compressing c if(dis.compres) then skip = (des_recs(k).flags .and. des_flag_compressed) .ne. 0 endif endif c if(.not. skip) then nk1 = des_recs(k).nam.dsc$w_maxstrlen c c Check if display wanted on match on fieldname c if(len(mask) .eq. 0 .or. 1 dix_util_match_string_wild(des_recs(k).nam, 1 mask,.false.,wild_flag))then c c We have a field that must be printed (the fieldname mask matches) c field_name = intro//field_name nk1 = len(intro) + nk1 c if(phase .eq. 1) then c c Just computing size of name field c if(dis.field) then if(des_recs(k).p_link_rec .ne. 0) nk1 = nk1 + 1 nk_min_1 = max(nk1,nk_min_1) endif goto 31 endif c c Here for the real print c nk_min_1 contains the length needed for the fieldname (and optional >) c if(display_all) then nfld_pr = nfld_pr + 1 if(dis.field) then if(des_recs(k).p_link_rec .ne. 0) 1 field_name(nk_min_1:nk_min_1) = '>' endif c c ## check for vfc c call dix_dump_display_all(control, 1 des_recs(k).bit_offset, 1 data,nb_data,file,nk1,.false., 1 field_name(1:nk_min_1)) goto 31 endif c c Normal print c offs = des_recs(k).bit_offset/8 if(offs .lt. nb_data) then c c Convert data to text c istat = dix_con_intasc(nb_data-offs,des_recs(k), 1 data,ascdat,nkar, 1 dis.hex, 1 max_len,control) if(istat .or. .not. dis.compres) then c c If /search also , see if match on contents c if(len(search) .ne. 0) then pp = dix_util_find_string_wild(ascdat(1:nkar), 1 search,endpos,.false.,wild_flag) if(pp .eq. 0) goto 31 end if c c Do display data, possibly in multiple lines c nk will contain the start info c nr|fieldname>| c nk = 0 c c Insert the offset (nk_off wide) + 1 for the | c if(dis.number) then call dix_util_con_nr(des_recs(k).bit_offset, 1 des_info.has_fields, 1 line,nk_off,dis.number_hex,control) nk = nk_off + 1 line(nk:nk) = '|' end if c c Insert the field, (if wanted) c nk_min_1 is the max size of the field )(+1 if field contains link_rec) c if(dis.field) then if(des_recs(k).p_link_rec .ne. 0) 1 field_name(nk_min_1:nk_min_1) = '>' endif c c See if we want the keyfields to be marked c if(file.indexed .and. mark) then set_bold = dix_rms_offset_in_key(file, 1 des_recs(k).bit_offset/8, 1 des_recs(k).size/8) else set_bold = .false. endif nk_fol = nk if(dis.field) then nk_fol = nk_fol + nk_min_1 + 1 if(set_bold) then nk1 = des_recs(k).nam.dsc$w_maxstrlen line(nk+1:) = bold_seq//field_name(1:nk_min_1)// 1 norm_seq nk = nk + nk_min_1 + len(bold_seq) + len(norm_seq) else line(nk+1:) = field_name(1:nk_min_1) nk = nk + nk_min_1 endif nk = nk + 1 line(nk:nk) = '|' endif bpos = 1 if(nkar .eq. 0) nkar = 1 !at least one line c c Start printing the whole line c do while(bpos .le. nkar) epos = min(bpos+control.ncols-nk_fol-1,nkar) line(nk+1:nk+epos-bpos+1) = ascdat(bpos:epos) if(.not. dix_write_file(control, 1 line(1:nk+epos-bpos+1),.false.)) goto 89 nk = nk_fol line(1:nk) = ' ' line(nk:nk) = '|' bpos = epos + 1 end do nfld_pr = nfld_pr + 1 c c If description display wanted, display description for this field c if(displ_des) then if(.not. display_des(control,0, 1 des_recs(k),0,4)) goto 89 endif end if !non blank data end if !offset still in record end if !Field name matches endif !compress matches 31 end do !Go through all fields end do !phase=1,2 istat = 1 if(nfld_pr .eq. 0) then istat = %loc(dix_msg_nofldfnd) err_arg = mask endif else c c Display raw c if(display_all) then c c All format display c if(dix_con_i4(mask,len(mask),offs, 1 dis.number_hex,control,.false.)) then call dix_dump_display_all(control,offs*8, 1 data,nb_data,file,nk1,.false., 1 'Raw display') else istat = %loc(dix_msg_nomaskoff) err_arg = mask endif else call dix_dump_vars(control,dis,kpl,fldsiz,posasc) if(len(mask) .eq. 0) then c c Display raw the whole record c k = 0 c if(header) then call dix_dump_create_header3(line,nkar,kpl,fldsiz,dis,posasc) call dix_dump_print_line(control,1,line(1:nkar)) endif c call dix_dump_file_dump(control,file,dis,k) else c c Display line containing offset[:offset] c call dix_dump_print_header(control,file,dis) c if(header) then call dix_dump_create_header3(line,nkar,kpl,fldsiz,dis,posasc) call dix_dump_print_line(control,1,line(1:nkar)) endif ipos = index(mask,':') if(ipos .eq. 0) then c c Only begin, this matches just one line c istat = dix_con_i4(mask,len(mask),offs, 1 dis.number_hex,control,.false.) end_offs = offs+kpl !offset starts at 0 else c c begin:end specified, c either c bpos:epos c :epos 0:epos c bpos: bpos:EOR c if(ipos .eq. 1) then offs = 0 istat = 1 else istat = dix_con_i4(mask,ipos-1,offs, 1 dis.number_hex,control,.false.) endif if(istat) then if(ipos .eq. len(mask)) then end_offs = nb_data else istat = dix_con_i4(mask(ipos+1:),len(mask)-ipos, 1 end_offs,dis.number_hex,control,.false.) end_offs = end_offs + 1 !we start at 0 endif endif endif if(istat) then if(end_offs .gt. nb_data) end_offs = nb_data do while(offs .le. end_offs) if(control.control_c_seen) goto 90 c c Display upto end_offs only (not nb_data) c call dix_dump_raw_line(control,offs,kpl,end_offs,data, 1 dis,posasc,begpos_bol,endpos_bol,n_bol, 1 line,nkar,fldsiz,file) call dix_dump_print_line(control,1,line(1:nkar)) offs = offs + kpl end do else istat = %loc(dix_msg_nomaskoff) err_arg = mask endif !con error on mask end if !mask=empty end if !display_all format end if !raw mode c 89 if(control.linenr .ne. old_nl) something= .true. c 90 dix_dump_displ = istat return end c function dix_dump_i_depo(control,dis,err_arg,totline) implicit none c c Deposit field=value c include 'dix_interactive.inc' record /control/ control !:i: control structure record /dis_pars/ dis !:i: display parameters character*(*) err_arg !:o: error argument character*(*) totline !:i: value to be deposited integer*4 dix_dump_i_depo !:f: function result c# character*(max_str_len) ascdat character*(max_line_length) fieldname,atemp integer*4 err_status,nk_data,ipos,nk_field,k,nk_atemp,plus integer*4 offs,value,ptr_file,ptr_des,p_des_recs,n_des_recs logical dep_vfc,repaint record /des_rec/ des_rec record /dis_pars/ dis_work c record /file_info/ file !:i: file pointer (p_file,file) c record /des_expanded/ des_expanded pointer (p_des_expanded, des_expanded) c c logical cli$present logical dix_con_typ_is_text logical dix_con_i4 logical dix_con_hex_ascint logical dix_con_int_ascint logical dix_dump_check_deposit logical dix_des_find_field logical dix_des_find_file_des c external dix_msg_notinmod external dix_msg_depform external dix_msg_fieldnotf external dix_msg_invbits external dix_msg_invusage external dix_msg_datalose external dix_msg_nomaskoff external dix_msg_outofvfc external dix_msg_outofrec external dix_msg_chgdrecl external dix_msg_synterr external dix_msg_readonly external dix_msg_synterrv external dix_msg_rectrunc external dix_msg_reclchg external dix_msg_invfsynt c err_status = 1 c c Check for VFC mode c dep_vfc = cli$present('VFC') c c Get the data c call cli$get_value('p1',ascdat,nk_data) ipos = index(ascdat(1:nk_data),'=') if(ipos .eq. 0) then err_status = %loc(dix_msg_depform) goto 90 endif c c Get the modify qualifiers c dis_work = dis call dix_inter_set_hex_mode(dis_work.hex) call dix_util_set_flag('NUMBER.HEX',dis_work.number_hex) call dix_util_set_flag('NUMBER', dis_work.number) call dix_util_Set_flag('RAW', dis_work.raw) c c Now try the data before the =, must be valid field name c of an offset c fieldname = ascdat(1:ipos-1) nk_field = ipos-1 c if(dix_des_find_field(control,fieldname(1:nk_field), 1 des_rec,.false.,ptr_file,dep_vfc)) then c c Got a match for the file c p_file = ptr_file offs = -1 !signal we have a match for fieldname else c c Did not find the fieldname c check if valid offset c syntax integer[.bit_offset] c if(dix_des_find_file_des(control,fieldname(1:nk_field), 1 ptr_file,ptr_des,ipos)) then p_file = ptr_file fieldname = fieldname(ipos:) nk_field = nk_field - ipos + 1 ipos = index(fieldname(1:nk_field),'.') if(ipos .eq. 0) then plus = 0 else read(fieldname(ipos+1:nk_field),2040,err=78) plus if(plus .lt. 0 .or. plus .gt. 7) goto 78 nk_field = ipos-1 end if if(.not. dix_con_i4(fieldname(1:nk_field),nk_field, 1 offs,dis_work.number_hex,control,.false.))goto 78 c c See if offset falls inside current record c offs = offs*8 + plus des_rec.ent_type = enttyp_int else c c Could not parse \file[\des\] part c goto 89 endif c end if c if(.not. file.modify) goto 75 c c Get the data from the orig buffer (Since DCL parses to upercase) c ascdat = totline nk_data = len(totline) c c Remove the = part (if present) c 101 ipos = index(ascdat(1:nk_data),'=') if(ipos .gt. 0) then ascdat = ascdat(ipos+1:) nk_data = nk_data - ipos endif c c If no char type, delete all spaces c if(.not. dix_con_typ_is_text(des_rec.ent_type) .and. 1 des_rec.ent_type .ne. enttyp_cpu) then call unspace(ascdat,nk_data) endif c dis_work.word = 0 if(cli$present('LONGWORD')) dis_work.word = 4*8 if(cli$present('WORD')) dis_work.word = 2*8 if(cli$present('BYTE')) dis_work.word = 1*8 call cli$get_value('bits',atemp,nk_atemp) if(nk_atemp .gt. 0) then read(atemp(1:nk_atemp),2040,err=81) dis_work.word 2040 format(i10) if(dis_work.word .ge. 1 .and. dis_work.word .le. 32) goto 81 endif c if(offs .lt. 0) then c c Description mode c if((des_rec.flags .and. des_flag_readonly) .ne. 0) then err_status = %loc(dix_msg_readonly) !,des_rec.nam) goto 90 endif if(dis_work.word .ne. 0) then err_status = %loc(dix_msg_invusage) goto 90 endif c if(p_file .eq. 0) goto 82 c c format c deposit[/quals] fieldname=value c Try to locate fieldname and see no duplicate possibilities c c Copy data to temp record, and try to convert there c p_des_expanded = file.cur_des if(dep_vfc) then n_des_recs = des_expanded.table_vfc.count p_des_recs = des_expanded.table_vfc.address else n_des_recs = des_expanded.table_nor.count p_des_recs = des_expanded.table_nor.address endif if(.not. dix_dump_check_deposit(control,file,des_rec, 1 n_des_recs, 1 %val(p_des_recs), 1 ascdat(1:nk_data), 1 dis_work,repaint,.false.,dep_vfc)) then err_status = %loc(dix_msg_synterr) else call dix_des_inv_des(control,file) end if else c c Raw mode c Format deposit[/quals] offset=value c Offset = byteoffset[.bit_offset] c value = data in integer format c c Try to convert offset to binary c if(dis_work.word .eq. 0) then dis_work.word = dis.word*8 !take command line if(dis_work.word .eq. 0) dis_work.word = 8!take def 1 byte endif c if(dep_vfc) then if(offs+8 .gt. file.data.nb_vfc*8) then err_status = %loc(dix_msg_outofvfc) goto 48 endif else if(offs+dis_work.word .gt. file.data.nb_data*8) then if(.not. ((file.indexed .or. file.relative) .and. .not. 1 file.fixed)) then err_status = %loc(dix_msg_outofrec) goto 48 else if(mod(offs+dis_work.word,8) .ne. 0) then file.data.nb_data = (offs+dis_work.word)/8+1 else file.data.nb_data = (offs+dis_work.word)/8 endif call dix_message(control,dix_msg_chgdrecl, 1 %val(file.data.nb_data)) call dix_des_inv_des(control,file) endif endif endif c c Now try to convert the data with dis_work.size to be the size in bits c if(dis_work.hex) then if(2*(nk_data/2) .ne. nk_data) then ascdat = '0'//ascdat(1:nk_data) nk_data = nk_data + 1 endif if(.not. dix_con_hex_ascint(ascdat(1:nk_data),value,0,4, 1 enttyp_int,control)) goto 49 else if(.not. dix_con_int_ascint(ascdat(1:nk_data),value, 1 dis_work.word,' ',0,0,control,.false.)) goto 49 endif c c COnvert successfull, now insert in the main data c if(dep_vfc) then call dix_util_insert_bits(value,offs,dis_work.word, 1 file.data.vfc_data) else call dix_util_insert_bits(value,offs,dis_work.word, 1 file.data.data_rec) endif call dix_des_inv_des(control,file) end if err_status = 1 goto 90 48 call sys$fao('!UL',k,err_arg,%val(offs/8)) err_arg(k+1:) = ' ' goto 90 c 49 err_arg = ascdat(1:nk_data) err_status = %loc(dix_msg_synterrv) goto 90 c 75 err_status = %loc(dix_msg_notinmod) goto 90 c 78 err_arg = fieldname(1:nk_field) err_status = %loc(dix_msg_nomaskoff) goto 90 c 81 err_arg = atemp(1:nk_atemp) err_status = %loc(dix_msg_invbits) goto 90 c 82 err_arg = fieldname(1:nk_field) err_status = %loc(dix_msg_fieldnotf) goto 90 c 89 err_status = %loc(dix_msg_invfsynt) err_arg = fieldname(1:nk_field) goto 90 c 90 dix_dump_i_depo = err_status return end options /exten function dix_dump_i_show_des_exp(control,n_des,des_recs, 1 has_fields,first_var) implicit none c c show dexciption expanded c include 'dix_interactive.inc' record /control/ control !:io: control integer*4 n_des !:i: #descriptions record /des_rec/ des_recs(*) !:i: the descriptions logical has_fields !:i: do we have field mode fields integer*4 dix_dump_i_show_des_exp !:f: the function result integer*4 first_var c# integer*4 k,nk,nk1,siz,wid_off,wid_typ,conmask,nk3,phase character*(max_line_length) line,work character*(max_nr_asc_length) nroff,nroff1 logical hex,full,field_mode c record /link_rec/ link_rec pointer (p_link_rec,link_rec) c integer*4 dix_dump_print_line integer*4 dix_dump_print_line_br logical cli$present c character*(max_keytype_length) matchfield c character*(*) matchfields parameter (matchfields = 'LT,LE,EQ,GE,GT') c k = first_var !to prevent compiler warnings full = cli$present('FULL') hex = cli$present('HEX') c c Compute width's for ofset and type field c wid_off = 0 wid_typ = 0 field_mode = .false. c c Display all descriptions c c in two phases, c the first to get the right width of the name field c the second to do the actual printing c wid_off = 0 wid_typ = 0 do phase=1,2 do k=1,n_des c c Compute the size for the offset field c if(phase .eq. 1) then nk = 0 else nk = wid_off endif call dix_util_con_nr(des_recs(k).bit_offset,has_fields, 1 nroff,nk,hex,control) if(phase .eq. 1 .and. nk .gt. wid_off) wid_off = nk c c And for the bit offset+size (if field has pad_value) c if(des_recs(k).pad_value .ne. 0) then call dix_util_con_nr(des_recs(k).bit_offset+ 1 des_recs(k).size,has_fields, 1 nroff1,nk,hex,control) if(phase .eq. 1 .and. nk .gt. wid_off) wid_off = nk endif c c Now the size for the type*size/flags c call dix_util_get_type_name(des_recs(k).ent_type,line,nk,siz) c c And the size c siz = des_recs(k).size if((des_recs(k).flags .and. des_flag_is_field) .eq. 0) siz = siz/8 call sys$fao('*!UL',nk1,line(nk+1:),%val(siz)) nk = nk + nk1 c c Optionally the special convert options c conmask = des_recs(k).flags .and. des_flag_translate_mask if(conmask .ne. des_flag_translate_nor) then if(conmask .eq. des_flag_translate_hex) line(nk+1:) = '/HEX' if(conmask .eq. des_flag_translate_oct) line(nk+1:) = '/OCT' if(conmask .eq. des_flag_translate_bin) line(nk+1:) = '/BIN' nk = nk + 4 endif conmask = des_recs(k).flags .and. des_flag_case_mask if(conmask .ne. des_flag_case_no_case) then if(conmask .eq. des_flag_case_upper) line(nk+1:) = '/UPP' if(conmask .eq. des_flag_case_lower) line(nk+1:) = '/LOW' nk = nk + 4 endif c c Check for follow fields c nk = nk + 1 if(des_recs(k).p_link_rec .ne. 0) line(nk:nk) = '>' c if(phase .eq. 1 .and. nk .gt. wid_typ) wid_typ = nk if(phase .eq. 1) goto 40 c c Now for the real printing c CHeck for change in fieldmode c nk = wid_typ c c Check for fieldmode switches c if(field_mode) then if((des_recs(k).flags .and. des_flag_is_field) .eq. 0) then field_mode = .false. if(.not.dix_dump_print_line(control,0,'NOFIELDMODE')) goto 90 endif else if((des_recs(k).flags .and. des_flag_is_field) .ne. 0) then field_mode = .true. if(.not.dix_dump_print_line(control,0,'FIELDMODE')) goto 90 endif endif c c Insert the name c call dix_util_copy_string(des_recs(k).nam,line(nk+1:)) nk = nk + des_recs(k).nam.dsc$w_maxstrlen c if(.not.dix_dump_print_line(control,0, 1 nroff(1:wid_off)//' '//line(1:nk))) goto 90 c if(des_recs(k).pad_value .ne. 0) then c if(field_mode) then call sys$fao('ALIGN*!UL',nk,line, 1 %val(des_recs(k).pad_value)) else call sys$fao('ALIGN*!UL',nk,line, 1 %val(des_recs(k).pad_value/bits_per_byte)) endif if(.not.dix_dump_print_line(control,0, 1 nroff1(1:wid_off)//' '//line(1:nk))) goto 90 endif c if(full) then c c If full, display for field display (text names for integers) c nk1 = wid_off + wid_typ + 2 if(des_recs(k).fldnam.dsc$w_maxstrlen .ne. 0) then if(.not.dix_dump_print_line_br(control,nk1, 1 des_recs(k).fldnam)) goto 90 endif c c Min/max values c if(des_recs(k).min_val .ne. des_recs(k).max_val) then call sys$fao('Minimum !UL, Maximum !UL',nk,line, 1 %val(des_recs(k).min_val), 1 %val(des_recs(k).max_val)) if(.not.dix_dump_print_line(control,nk1,line(1:nk))) goto 90 endif c c And follow field c if(des_recs(k).p_link_rec .ne. 0) then p_link_rec = des_recs(k).p_link_rec if(.not.dix_dump_print_line(control,nk1,'link record')) goto 90 if(link_rec.nk_link_file .ne. 0) then if(.not. dix_dump_print_line(control,nk1+2,'File:'// 1 link_rec.link_file(1:link_rec.nk_link_file))) goto 90 endif if(link_rec.key_nr .lt. 0) then call sys$fao('/RECORD',nk,line) else call str$element(matchfield,link_rec.match+2,',',matchfields) call sys$fao('/KEY=!UL/MATCH=!AS',nk,line, 1 %val(link_rec.key_nr),matchfield) endif if(.not. dix_dump_print_line(control,nk1+2,line(1:nk))) goto 90 if(link_rec.if_line.dsc$w_maxstrlen .ne. 0) then call dix_util_copy_string(link_rec.if_line,work) nk3 = link_rec.if_line.dsc$w_maxstrlen if(.not. dix_dump_print_line(control,nk1+2,'If:'// 1 work(1:nk3))) goto 90 endif if(link_rec.comp_line.dsc$w_maxstrlen .ne. 0) then call dix_util_copy_string(link_rec.comp_line,work) nk3 = link_rec.comp_line.dsc$w_maxstrlen if(.not. dix_dump_print_line(control,nk1+2,'Compute:'// 1 work(1:nk3))) goto 90 endif endif !there is a link_record endif !full display 40 end do !k=1,ndes end do !phase=1,2 90 dix_dump_i_show_des_exp = 1 return end subroutine dix_inter_list_keys(control) implicit none c c List interactive mode keys c include 'dix_interactive.inc' include '($smgdef)' record /control/ control !:io: control structure c# character*(max_line_length) line character*(max_symbol_name_length) keyname,if_state,equiv,set_state character*(max_symbol_name_length) key_w,state_w integer*4 nk_k,nk_if,nk_eq,nk_se,n,nk,nk_kw,nk_sw,ctx,flags integer*4 mem_lun logical full c integer*4 dix_util_get_len_fu integer*4 smg$list_key_defs integer*4 str$match_wild logical cli$present logical dix_dump_print_line integer*4 dix_util_get_len external dix_msg_nokeys integer memtab_read c if(cli$present('DIRECTORY')) then c c Display a directory of states c call memtab_init(control,mem_lun,'Directory') ctx = 0 if(.not. dix_dump_print_line(control,0, 1 'Directory of key-states')) goto 15 do while(smg$list_key_defs(control.keytable_id,ctx, 1 keyname,if_state,flags,equiv,set_state)) call memtab_rewind(mem_lun) nk_if = dix_util_get_len(if_state) do while(memtab_read(mem_lun,nk,line)) if(line(1:nk) .eq. if_state(1:nk_if)) goto 10 end do call memtab_add_record(control,mem_lun,if_state(1:nk_if)) 10 end do call memtab_rewind(mem_lun) do while(memtab_read(mem_lun,nk,line)) if(.not. dix_dump_print_line(control,2,line(1:nk))) then goto 15 end if end do 15 call memtab_close(control,mem_lun) goto 90 endif c c Display the wanted keys c call cli$get_value('p2',key_w,nk_kw) if(nk_kw .eq. 0) then key_w = '*' nk_kw = 1 endif call cli$get_value('state',state_w,nk_sw) if(nk_sw .eq. 0) then state_w = 'DEFAULT' nk_sw = 7 endif if(.not. dix_dump_print_line(control,0, 1 state_w(1:nk_sw)//' keypad definitions')) goto 90 full = cli$present('full') ctx = 0 n = 0 do while(smg$list_key_defs(control.keytable_id,ctx, 1 keyname,if_state,flags,equiv,set_state)) nk_k = dix_util_get_len_fu(keyname) nk_if = dix_util_get_len_fu(if_state) nk_eq = dix_util_get_len_fu(equiv) nk_se = dix_util_get_len_fu(set_state) if(str$match_wild(keyname(1:nk_k),key_w(1:nk_kw)) .and. 1 if_state(1:nk_if) .eq. state_w(1:nk_sw)) then n = n + 1 line = keyname(1:nk_k)//' = "'//equiv(1:nk_eq)//'"' nk = nk_k + 4 + nk_eq + 1 if(full) then nk = nk + 2 line(nk:nk) = '(' if(iand(flags,smg$m_key_noecho) .ne. 0) then call dix_append(nk,line,'NOECHO,') else call dix_append(nk,line,'ECHO,') endif c if(iand(flags,smg$m_key_terminate) .ne. 0) then call dix_append(nk,line,'TERMINATE,') else call dix_append(nk,line,'NOTERMINATE,') endif if(iand(flags,smg$m_key_lock) .ne. 0) then call dix_append(nk,line,'LOCK,') else call dix_append(nk,line,'NOLOCK,') endif if(iand(flags,smg$m_key_protected) .ne. 0) then call dix_append(nk,line,'PROTECTED') else call dix_append(nk,line,'NOPROTECTED') endif if(nk_se .gt. 0) then call dix_append(nk,line,',STATE='//set_state(1:nk_se)//')') else call dix_append(nk,line,')') endif end if if(.not. dix_dump_print_line(control,2,line(1:nk))) goto 90 endif end do if(n .eq. 0) call dix_message(control,dix_msg_nokeys, 1 state_w(1:nk_sw)) 90 return end subroutine set_strict(strict) implicit none c c Set strict mod c include 'dix_interactive.inc' integer*4 strict !:o: strict flag c# integer*4 istat logical*4 dix_util_set_flag c if(dix_util_set_flag('TYPING',istat)) then if(istat) then strict = strict .or. strict_typing else strict = strict .and. .not. strict_typing endif endif c if(dix_util_set_flag('DECLARATIONS',istat)) then if(istat) then strict = strict .or. strict_declaration else strict = strict .and. .not. strict_declaration strict = strict .and. .not. strict_declaration_local endif endif c if(dix_util_set_flag('LOCAL',istat)) then if(istat)then strict = strict .or. strict_declaration strict = strict .or. strict_declaration_local else strict = strict .and. .not. strict_declaration strict = strict .and. .not. strict_declaration_local endif endif return end function dix_inter_read_command_file(control,file,file_level) implicit none c c Readin a command file to a memory file c the file is checked on syntax for the c control structures, any mismatch results in an message and an error c include 'dix_interactive.inc' record /control/ control !:io: control structure character*(*) file !:i: filename record /file_level/ file_level !:io: file level structure integer*4 dix_inter_read_command_file !:f: status c# integer*4 istat,lun_f,lun_mem,nlin c integer*4 dix_inter_read_command_memtab integer*4 dix_util_get_len_fu c c Open the file, it should exists, since SMG already opened it c call lib$get_lun(lun_f) open(lun_f,file=file,status='old',err=80,defaultfile='.dix') inquire(lun_f,name=file_level.filename) file_level.nk_file = dix_util_get_len_fu(file_level.filename) c c Copy the file to a memtab c call memtab_open_lun(control,lun_f,lun_mem,nlin) close(lun_f) c c Create new memtab (contains precompiled source) c call memtab_init(control,file_level.lun,file) c c And parse it c istat = dix_inter_read_command_memtab(lun_mem,control,file_level) call memtab_close(control,lun_mem) goto 90 c 80 call errsns(,istat) c 90 call lib$free_lun(lun_f) dix_inter_read_command_file = istat return end function dix_inter_read_command_usertype(lun_mem,control,name, 1 lun_usertypes) implicit none c c A simple interface for command_memtab c include 'dix_interactive.inc' record /control/ control !:i: control structure character*(*) name !:i: the rquested user type integer*4 lun_mem !:o: the lun integer*4 lun_usertypes !:i: usertype lun c# integer*4 dix_inter_read_command_usertype c integer*4 istat,nlin,lun,ptr_line,k,nk character*(max_label_length) label character*(max_command_length) line c record /file_level/ file_level c integer*4 dix_inter_read_command_memtab integer*4 dix_lbr_read_module integer*4 memtab_open integer*4 memtab_read logical memtab_find_label logical dix_des_is_type c external dix_msg_usrtnotf c c First try to find in the lun_usertype c istat = memtab_find_label(lun_usertypes,name,ptr_line,k) if(istat) then call memtab_set_line_ptr(lun_usertypes,ptr_line) c c Skip first line, it contains the label c call memtab_init(control,lun,'USERTYPE_'//name) c call memtab_read(lun_usertypes,nk,line) do while(memtab_read(lun_usertypes,nk,line)) if(dix_des_is_type(line(1:nk),.false.,label)) goto 10 call memtab_add_record(control,lun,line(1:nk)) end do endif c 10 if(.not. istat) then c c Try to open in the current directory c istat = memtab_open(control,'USERTYPE_'//name,lun,nlin) endif if(.not. istat) then c c Try to read from one of the libraries c istat = dix_lbr_read_module(control,'USERTYPE_'//name,lun,nlin) endif c if(istat) then call memtab_rewind(lun) call memtab_init(control,file_level.lun,'USERTYPE_'//name) istat = dix_inter_read_command_memtab(lun,control,file_level) lun_mem = file_level.lun !tell caller call memtab_close(control,lun) !delete lun else call dix_message(control,dix_msg_usrtnotf,name) endif dix_inter_read_command_usertype = istat return end c function dix_inter_read_command_memtab(lun_mem,control,file_level) implicit none c c Readin a command file to a memory file c the file is checked on syntax for the c control structures, any mismatch results in an message and an error c include 'dix_interactive.inc' integer*4 lun_mem !:i: lun with the source file record /control/ control !:io: control structure record /file_level/ file_level !:io: file level structure integer*4 dix_inter_read_command_memtab !:f: status c# character*(max_str_len) line,tot_line character*(max_label_length) label c record /struct_pointers/ ptrs record /struct_level/ struct_level pointer (p_struct_level,struct_level) c character*(max_verb_length) verb c integer*4 line_ptr integer*4 istat integer*4 nk,nk_tot,pos,beg_line_nr,xlev,nk1 logical first c record /level_info/ level c integer*4 dix_inter_get_label integer*4 memtab_read integer*4 dix_util_get_len_fu integer*4 str$find_first_in_set c external dix_msg_notpart external dix_msg_wrongblock external dix_msg_openlevel external dix_msg_errcmnd external dix_msg_multielse external dix_msg_contlnotf external dix_msg_noopstr external dix_msg_openbnotf external dix_msg_errinline c call dix_inter_open_struct(control,file_level,ptrs) p_struct_level = file_level.cur_struct c c Init c level.level = 1 level.line_nr = 0 c c Start reading c 10 nk_tot = 0 first = .true. 20 istat = memtab_read(lun_mem,nk,line) if(.not. istat) goto 50 c level.line_nr = level.line_nr + 1 call memtab_add_record_level(control,file_level.lun,line(1:nk),level) c if(first) then call memtab_get_line_ptr(file_level.lun,line_ptr) beg_line_nr = level.line_nr endif first = .false. call dix_util_remove_comment(nk,line) call dix_util_decent_line(nk,line) tot_line(nk_tot+1:nk_tot+nk) = line(1:nk) nk_tot = nk_tot + nk if(nk_tot .gt. 0) then if(tot_line(nk_tot:nk_tot) .eq. '-') then nk_tot = nk_tot - 1 goto 20 endif endif if(nk_tot .eq. 0) goto 10 c c Change some special statements c call dix_inter_massage(tot_line,nk_tot) c c Now we have a total line tot_line(1:nk_tot) c find the (optional) label and the verb c if(dix_inter_get_label(tot_line(1:nk_tot),label,pos)) then if(tot_line(pos:pos) .eq. ' ') pos = pos + 1 tot_line = tot_line(pos:nk_tot) nk_tot = nk_tot - pos + 1 call memtab_add_label(control,file_level.lun,line_ptr,label,pos) else label = ' ' endif c c Now get verb, this is the part upto the space or / c pos = str$find_first_in_set(tot_line(1:nk_tot),' =(/') if(pos .eq. 0) pos = nk_tot+1 if(pos .gt. 0) pos = pos - 1 if(pos .gt. 4) pos = 4 call str$upcase(verb,tot_line(1:pos)) c c CHeck for end verbs c if(verb .eq. 'ENDF' .or. verb .eq. 'ENDW' .or. 1 verb .eq. 'UNTI' .or. verb .eq. 'ENDL' .or. 1 verb .eq. 'ENDI' .or. verb .eq. 'ENDS') then if(level.level .le. 1) goto 66 if(verb .eq. 'UNTI') then if(struct_level.ptrs.begin_verb .ne. 'REPE') goto 62 else if(verb(4:4) .ne. struct_level.ptrs.begin_verb(1:1)) goto 62 endif struct_level.ptrs.end_ptr = line_ptr struct_level.ptrs.end_nr = beg_line_nr c c Now store the extra info for the begin_line c call memtab_add_pointers(control,file_level.lun, 1 sizeof(struct_level.ptrs), 1 struct_level.ptrs,struct_level.ptrs.begin_ptr) call dix_inter_close_struct(control,file_level) p_struct_level = file_level.cur_struct level.level = level.level - 1 endif c c Check for middle verbs c xlev = level.level if(verb .eq. 'ELSE') then if(level.level .le. 1) goto 60 if(struct_level.ptrs.begin_verb .ne. 'IF') goto 60 if(struct_level.ptrs.middle_ptr .ne. 0) goto 65 struct_level.ptrs.middle_ptr = line_ptr struct_level.ptrs.middle_nr = beg_line_nr xlev = xlev - 1 endif if(verb .eq. 'TEST') then if(level.level .le. 1) goto 61 if(struct_level.ptrs.begin_verb .ne. 'LOOP') goto 61 xlev = xlev - 1 endif c if((control.debug .and. debug_command) .ne. 0) then nk = min(nk_tot,80-2*xlev-15) if(label .ne. ' ') then nk1 = dix_util_get_len_fu(label) label(nk1+1:nk1+1) = ':' nk1 = nk1 + 1 else nk1 = 0 endif call sys$fao('!4UL !2UL !#* !AS',nk,line, 1 %val(beg_line_nr), 1 %val(level.level), 1 %val(2*xlev), 1 label(1:nk1)//tot_line(1:nk)) call dix_main_print_debug(control,debug_command,line(1:nk)) endif c c Now check for begin verbs c if(verb .eq. 'FOR' .or. 1 verb .eq. 'WHIL' .or. 1 verb .eq. 'REPE' .or. 1 verb .eq. 'LOOP' .or. 1 verb .eq. 'IF' .or. 1 verb .eq. 'SUBR') then if(verb .eq. 'IF') then c c The IF statement can have 2 forms c IF (expres) THEN c IF (expres) statement c Only format 1 creates a new level c if(tot_line(pos+1:pos+2) .ne. ' (' .and. 1 tot_line(pos+1:pos+1) .ne. '(') then c c We must have IF ( or IF( c call dix_message(control,dix_msg_openbnotf) goto 70 endif if(tot_line(nk_tot-5:nk_tot) .ne. ') THEN' .and. 1 tot_line(nk_tot-4:nk_tot) .ne. ')THEN') goto 40 endif level.level = level.level + 1 call dix_inter_open_struct(control,file_level,ptrs) p_struct_level = file_level.cur_struct c struct_level.ptrs.begin_verb = verb struct_level.ptrs.begin_ptr = line_ptr struct_level.ptrs.begin_nr = beg_line_nr struct_level.ptrs.middle_ptr = 0 struct_level.ptrs.middle_nr = 0 struct_level.ptrs.end_ptr = 0 struct_level.ptrs.end_nr = 0 endif c c c If label present, store the label info c 40 goto 10 c c Eof reached, close the file and exit c 50 if(level.level .gt. 1) goto 63 if(.not. first) goto 64 istat = 1 call memtab_rewind(file_level.lun) goto 90 c 60 call dix_message(control,dix_msg_notpart,verb, 1 %val(level.line_nr),%descr('IF')) goto 70 c 61 call dix_message(control,dix_msg_notpart,verb,%val(level.line_nr), 1 %descr('LOOP')) goto 70 c 62 call dix_message(control,dix_msg_wrongblock, 1 verb,%val(level.line_nr), 1 struct_level.ptrs.begin_verb, 1 %val(struct_level.ptrs.begin_nr)) goto 70 c 63 call dix_message(control,dix_msg_openlevel, 1 struct_level.ptrs.begin_verb, 1 %val(struct_level.ptrs.begin_nr)) goto 70 c 64 call dix_message(control,dix_msg_contlnotf) goto 70 c 65 call dix_message(control,dix_msg_multielse) goto 70 66 call dix_message(control,dix_msg_noopstr, 1 verb,%val(level.line_nr)) goto 70 c 70 call dix_message(control,dix_msg_errinline,tot_line(1:nk_tot)) istat = %loc(dix_msg_errcmnd) call memtab_close(control,file_level.lun) goto 90 c c Delete all temporary struct_levels c 90 do while(file_level.cur_struct .ne. 0) call dix_inter_close_struct(control,file_level) end do c dix_inter_read_command_memtab = istat return end function dix_inter_find_label(label,goto_level, 1 err_arg,nlevel,file_level,control) implicit none c c Try to find a label c include 'dix_interactive.inc' character*(*) label !:i: the label to be found record /level_info/ goto_level !:i: the level of the go(to/sub) line character*(*) err_arg !:o: the error argument integer*4 nlevel !:o: #levels down record /file_level/ file_level !:i: command file record /control/ control !:i: control block logical dix_inter_find_label !:f: function result c# integer*4 lun integer*4 ptr_line,label_line record /level_info/ label_level c record /struct_level/ struct_level pointer (p_struct_level,struct_level) c external dix_msg_labnotr external dix_msg_labnotf c integer*4 istat, k,blin,elin,nk_l ,nk character*(max_line_length) line c integer*4 memtab_find_label integer*4 dix_util_get_len_fu c lun = file_level.lun istat = 0 nk_l = dix_util_get_len_fu(label) c if((control.debug .and. debug_command) .ne. 0) then call sys$fao(' Search label !AS from Goto at '// 1 'level !UL, line !UL',nk,line, 1 label(1:nk_l),%val(goto_level.level), 1 %val(goto_level.line_nr)) call dix_main_print_debug(control,debug_command,line(1:nk)) endif c if(memtab_find_label(lun,label,ptr_line,label_level)) then c c Now goto_level is the level of the goto line c label_level is the level of the label line c see if reachable c c If label is at level 1, is can be reached from anywhere. c if((control.debug .and. debug_command) .ne. 0) then call sys$fao(' Label !AS found at '// 1 'level !UL, line !UL',nk,line, 1 label(1:nk_l),%val(label_level.level), 1 %val(label_level.line_nr)) call dix_main_print_debug(control,debug_command,line(1:nk)) endif label_line = label_level.line_nr c p_struct_level = file_level.top_struct do k=2,label_level.level if((control.debug .and. debug_command) .ne. 0) then call sys$fao(' Level !UL Verb !AS, beg !UL, Mid !UL, End !UL', 1 nk,line, 1 %val(k),struct_level.ptrs.begin_verb, 1 %val(struct_level.ptrs.begin_nr), 1 %val(struct_level.ptrs.middle_nr), 1 %val(struct_level.ptrs.end_nr)) call dix_main_print_debug(control,debug_command,line(1:nk)) endif if(struct_level.ptrs.middle_nr .eq. 0) then c c Only begin and end are interesting c blin = struct_level.ptrs.begin_nr elin = struct_level.ptrs.end_nr else if(goto_level.line_nr .lt. struct_level.ptrs.middle_nr) then blin = struct_level.ptrs.begin_nr elin = struct_level.ptrs.middle_nr else blin = struct_level.ptrs.middle_nr elin = struct_level.ptrs.end_nr endif endif if((control.debug .and. debug_command) .ne. 0) then call sys$fao(' Check if label !AS is between !UL and !UL', 1 nk,line,label_line,%val(blin),%val(elin)) call dix_main_print_debug(control,debug_command,line(1:nk)) endif if(label_line .lt. blin .or. label_line .gt. elin) goto 60 p_struct_level = struct_level.link.forw end do c call memtab_set_line_ptr(lun,ptr_line) istat = 1 c c Now compute how many levels we went down c nlevel = goto_level.level - label_level.level goto 90 60 istat = %loc(dix_msg_labnotf) err_arg = label else istat = %loc(dix_msg_labnotf) err_arg = label endif c 90 dix_inter_find_label = istat return end function dix_inter_parse_for(control,ascdat,symbol,nk_symb, 1 err_arg,des_expanded,begval,incval,endval) implicit none c c Parse the FOR argument c for symbol=begin.end[,increment] c include 'dix_interactive.inc' c record /control/ control character*(*) ascdat !:i: the command line character*(*) symbol !:o: the symbol integer*4 nk_symb !:o: lenght of symbol character*(*) err_arg !:o: error argument integer*4 des_expanded !:i: description integer*4 begval !:o: begval integer*4 incval !:o: increment val integer*4 endval !:o: end val integer*4 dix_inter_parse_for !:f: the result c# integer*4 ipos,nk integer*4 err_status character kar c integer*4 dix_symbol_check_name integer*4 dix_inter_eval_int external dix_msg_illfor external dix_msg_infloop c nk = len(ascdat) c c FInd the = character c ipos = index(ascdat,'=') if(ipos .eq. 0) goto 80 c c The symbol is the part upto to =, get and check c nk_symb = ipos-1 symbol = ascdat(1:nk_symb) err_status = dix_symbol_check_name(symbol(1:nk_symb), 1 des_expanded,err_arg) if(.not. err_status) goto 90 c c And the expression the rest c ascdat = ascdat(ipos+1:) nk = nk - ipos c c Now we have a symbol name c Parse first part (startpoint) c err_status = dix_inter_eval_int(control,ascdat,nk,begval,err_arg,kar) if(.not. err_status) goto 90 if(kar .ne. ',') goto 80 c c Now parse second part (endpoint) c err_status = dix_inter_eval_int(control,ascdat,nk,endval,err_arg,kar) c if(.not. err_status) goto 90 c c Now optional get the increment c incval = 1 if(kar .eq. ',') then err_status = dix_inter_eval_int(control,ascdat,nk,incval,err_arg,kar) c if(.not. err_status) goto 90 endif if(kar .ne. NULL) goto 80 c c Now we have all ingredients, begval,endval,incval c check for sanity c if(endval .lt. begval) then if(incval .ge. 0) goto 81 else if(incval .le. 0) goto 81 endif err_status = 1 goto 90 c 80 err_status = %loc(dix_msg_illfor) goto 90 81 err_status = %loc(dix_msg_infloop) goto 90 c 90 dix_inter_parse_for = err_status return end function dix_inter_eval_int(control,line,nk,ival,err_arg,kar) c c Evaluate string and return an integer c implicit none c include 'dix_interactive.inc' record /control/ control character*(*) line integer*4 nk integer*4 ival character*(*) err_arg character kar logical dix_inter_eval_int c# integer*4 istat,pos,is_symbol integer*4 dix_eval_expression1 external dix_msg_enotint record /value/ val c call dix_eval_init_value(val) istat = dix_eval_expression1(control,line(1:nk),val, 1 .false.,err_arg,.false., 1 kar,pos,is_symbol) if(istat) then if(val.type .eq. symb_typ_int) then istat = 1 else err_arg = line(1:pos-2) istat = %loc(dix_msg_enotint) endif ival = val.ival endif line = line(pos:) nk = nk - pos + 1 call dix_eval_free_value(val) dix_inter_eval_int = istat return end c function dix_inter_open_level(control,line,output_file) implicit none c c Open a new commandfile level c include 'dix_interactive.inc' include '($rmsdef)' include '($smgdef)' include '($dcdef)' include '($dvidef)' record /control/ control !:io: control structure character*(*) line !:i: filename character*(*) output_file !:i: output file integer*4 dix_inter_open_level !:f: the function result c# record /file_level/ file_level pointer (p_file_level,file_level) c integer*4 istat,lun_out,k,lun,old_strict logical ver_mode external dix_msg_filnotop record /smgdef/ keyboard_info c integer*4 smg$create_virtual_keyboard integer*4 dix_inter_read_command_file integer*4 dix_inter_create_new_level c c Gtet the old strict level, is gets inherited c p_file_level = control.cur_level if(p_file_level .ne. 0) then old_strict = file_level.strict_mode else old_strict = control.strict_mode endif c c Try to open virtual keyboard c istat = smg$create_virtual_keyboard(lun,line,'.DIX',,255) if(istat) then c c Create new level c istat = dix_inter_create_new_level(control) if(.not. istat) goto 90 p_file_level = control.cur_level c file_level.lun = lun file_level.filename = line file_level.nk_file = len(line) file_level.strict_mode = old_strict c c Could open terminal/file, Now get type of input device (file/terminal) c call smg$get_keyboard_attributes(file_level.lun, 1 keyboard_info,smg$c_keyboard_info_block) c c Set .is_term according to input type (file/terminal) c file_level.is_term = keyboard_info.smg$b_devclass.ne.dc$_disk c c Set default error action (on error then exit) c if(output_file .ne. ' ') then call lib$get_lun(lun_out) file_level.output_opened = .true. open(lun_out, 1 file=output_file, 1 status='new', 1 carriagecontrol='list',err=70, 1 recl=max_command_length) else file_level.output_opened = .false. if(control.depth .eq. 1) then ver_mode = .false. lun_out = control.lun_out else k = p_file_level p_file_level = file_level.link.backw ver_mode = file_level.verify lun_out = file_level.lun_out p_file_level = k endif endif file_level.verify = ver_mode !set verify file_level.lun_out = lun_out c if(.not. file_level.is_term) then c c Sys$input is a file c delete keyboard and read the imput file to a memtab c (with partial parsing for control structures) c call smg$delete_virtual_keyboard(file_level.lun) istat = dix_inter_read_command_file(control,line,file_level) if(.not. istat) goto 80 endif c call dix_inter_set_default_error(file_level) else if(istat .eq. rms$_fnf) istat = %loc(dix_msg_filnotop) endif goto 90 c c Open error on output file c 70 call errsns(,istat) if(istat .eq. rms$_fnf) istat = %loc(dix_msg_filnotop) c goto 80 c c Open error on command file parsing c 80 call dix_inter_close_level(control,.true.) c 90 dix_inter_open_level = istat return end function dix_inter_create_new_level(control) implicit none c c Create a new @ level c include 'dix_interactive.inc' record /control/ control integer*4 dix_inter_create_new_level c# integer*4 istat integer*4 nk character*(max_nr_asc_length) levelasc c record /gosub_entry/ gosub_entry c record /file_level/ file_level pointer (p_file_level,file_level) c c call sys$fao('!UL',nk,levelasc,%val(control.depth)) c call get_vm(control,sizeof(file_level),p_file_level, 1 control.zone_cfile,.false.,'FILE_LEVEL') file_level.magic = magic_file_level c c Now link in c call dix_inter_insert_link(file_level,control.top_level, 1 control.cur_level,control.depth) call init_vm(control,file_level.zone_level,0, 1 'FILE_LEVEL_'//levelasc(1:nk),.false.) c c Init some counters c file_level.struct_level = 0 !no structs yet file_level.cur_struct = 0 file_level.top_struct = 0 c call dix_util_init_table(file_level.gosubs,sizeof(gosub_entry)) c file_level.output_opened= .false. !No output open yet c file_level.on_mode = .false. !no control_c yet call dix_util_clear_descr(file_level.on_control_c_line,.true.) call dix_util_clear_descr(file_level.on_line,.true.) istat = 1 dix_inter_create_new_level = istat return end subroutine dix_inter_close_level(control,close_file) implicit none c c Close a level (exit/endsubroutine statement) c include 'dix_interactive.inc' record /control/ control logical close_file !really close the input file c# record /file_level/ file_level pointer (p_file_level,file_level) c p_file_level = control.cur_level if(.not. file_level.is_call) then c c Twas an @, so close the input terminal/memfile c if(file_level.is_term) then call smg$delete_virtual_keyboard(file_level.lun) else if(close_file) call memtab_close(control,file_level.lun) endif endif c c moet alle struc_levels sluiten van dit level c do while(file_level.struct_level .gt. 0) call dix_symbol_delete_level(control) call dix_inter_close_struct(control,file_level) enddo c call dix_symbol_delete_level(control) c if(file_level.output_opened) then close(file_level.lun_out) call lib$free_lun(file_level.lun_out) endif call dix_inter_remove_link(control.top_level,control.cur_level, 1 control.depth) call delete_vm(control,file_level.zone_level) call dix_util_free_descr(file_level.on_control_c_line) call dix_util_free_descr(file_level.on_line) call free_vm(control,sizeof(file_level),p_file_level, 1 control.zone_cfile) c return end subroutine dix_inter_set_default_error(level) implicit none c c Set default error action correct : on error exit c include 'dix_interactive.inc' include '($stsdef)' record /file_level/ level c# level.on_mode = .true. call dix_util_free_descr(level.on_line) call dix_util_clear_descr(level.on_line,.true.) level.on_level = sts$k_error return end subroutine dix_inter_get_struct_level(control,level) implicit none c c Get the current level c include 'dix_interactive.inc' record /control/ control integer*4 level c# record /file_level/ file_level pointer (p_file_level,file_level) c if(control.cur_level .eq. 0) then level = 0 else p_file_level = control.cur_level level = file_level.struct_level endif return end subroutine dix_inter_insert_link(link,top,last,count) implicit none c c insert a token in a link c include 'dix_def.inc' record /link/ link !:io: link block integer*4 top !:io: top pointer integer*4 last !:io: last pointer integer*4 count !:io: count of blocks c# record /link/ p_link pointer (p_p_link,p_link) c link.backw = last link.forw = 0 if(last .eq. 0) then top = %loc(link) else p_p_link = last p_link.forw = %loc(link) endif last = %loc(link) count = count + 1 return end c subroutine dix_inter_remove_link(top,last,count) implicit none c c Remove the last token in a link c include 'dix_def.inc' integer*4 top !:io: top pointer integer*4 last !:io: alst pointer integer*4 count !:io: count of blocks c# record /link/ link pointer (p_link,link) c p_link = last p_link = link.backw if(p_link .eq. 0) then top = 0 else link.forw = 0 endif last = p_link count = count - 1 return end subroutine dix_inter_get_file_level_info(control,what,nk,line) implicit none c c Get some info about current file_level c this routine is made so that other module do not need to know c the layout of the /file_level/ structure c include 'dix_interactive.inc' record /control/ control !:i: control structure character*(*) what !:i: item to get info about integer*4 nk !:o: length or integer value character*(*) line !:o: text ingo c# include '($stsdef)' c record /file_level/ file_level pointer (p_file_level,file_level) c p_file_level = control.cur_level if(what(1:2) .eq. 'PR') then nk = file_level.nk_file line = file_level.filename elseif(what(1:2) .eq. 'OA') then if(file_level.on_mode) then nk = file_level.on_line.dsc$w_maxstrlen call dix_util_copy_string(file_level.on_line,line) else line = 'None' nk = 4 endif elseif(what(1:2) .eq. 'OS') then if(file_level.on_mode) then if(file_level.on_level .eq. sts$k_warning) then line = 'WARNING' elseif(file_level.on_level .eq. sts$k_error) then line = 'WARNING' elseif(file_level.on_level .eq. sts$k_severe) then line = 'WARNING' endif else line = 'NONE' endif nk = index(line,' ')-1 elseif(what(1:2) .eq. 'LU') then nk = file_level.lun_out elseif(what(1:2) .eq. 'FI') then nk = .not. file_level.is_term endif return end subroutine dix_dump_inter_dir_files(control,full, 1 do_descr,all) implicit none c c LEt the user select a file from the file list c or display a list of file c File mask can be c include 'dix_def.inc' record /control/ control !:i: control structure logical full !:i: full file display logical do_descr !:i: show descriptions too logical all !:i: all files? 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 logical dix_dump_print_line integer*4 dix_dump_inter_next_file c integer*4 k,width,nk,nk_h,nk_s,nk_f,nk1 integer*4 ptr_file character*(max_short_line_length) ftyp,countasc character*(max_line_length) line,hline character file_mask character kar c external dix_msg_nofilmat c c Either show all files (possibly full) c or select a file c First compute the length of various parts c file_mask = ' ' if(all) file_mask = '*' c nk_h = 3 !max handle size nk_s = 4 !min filesize size (NE should fit) nk_f = 0 !max filename length ptr_file = 0 do while(dix_dump_inter_next_file(control,ptr_file,file_mask, 1 wildcard_flag_standard)) p_file = ptr_file c call sys$fao('!UL',k,line,%val(file.filesize)) if(k .gt. nk_s) nk_s = k c nk = file.nk_handle if(nk .gt. nk_h) nk_h = nk if(do_descr) then p_des_expanded = file.top_des do while(p_des_expanded .ne. 0) nk = des_expanded.nk_handle+ 1 if(nk .gt. nk_h) nk_h = nk p_des_info = des_expanded.p_des_info call dix_des_display(control,des_info,line,nk,.true.) if(nk .gt. nk_f) nk_f = nk call sys$fao('!UL',k,line, 1 %val(des_expanded.table_nor.count+ 1 des_expanded.table_vfc.count)) if(k .gt. nk_s) nk_s = k p_des_expanded = des_expanded.link.forw enddo end if call sys$fao('!UL',k,line,%val(file.filesize)) if(k .gt. nk_s) nk_s = k c c Filename is appended by /MOD c nk = file.nk_fnam if(file.modify) nk = nk + 4 !/mod c if(nk .gt. nk_f) nk_f = nk end do c c Now print the line c the format is c Tcc:hh filexx ss c T = current 1 char c hh = handle nk_h char c 8 = filetype 8 chars SEQ/FIX + space c ss = size of file nk_s char c width = min(nk_f,control.ncols-2-nk_h-1 - 7 -1 - nk_s - 1) kar = 'C' line = 'Filename' ftyp = 'Type' call sys$fao('!AS !#AS !AS !AS !#AS',nk,hline, 1 kar, 1 %val(nk_h),%descr('TAG'),ftyp(1:7), 1 line(1:width), 1 %val(nk_s),%descr('Size')) if(.not. dix_dump_print_line(control,0,hline(1:nk))) goto 90 c if(all) then p_file = control.top_file else p_file = control.cur_file endif ptr_file = 0 do while(dix_dump_inter_next_file(control,ptr_file,file_mask, 1 wildcard_flag_standard)) p_file = ptr_file ftyp = 'SEQ' if(file.relative) ftyp = 'REL' if(file.indexed ) ftyp = 'IDX' if(file.fixed ) ftyp(4:) = '/FIX' c width = min(nk_f,control.ncols-2-nk_h-1 - len(ftyp) -1 - nk_s -1) width = min(nk_f,control.ncols-2-nk_h-1 - 7 -1 - nk_s -1) if(file.modify) width = width - 4 call lib$trim_filespec(file.fnam(1:file.nk_fnam),line,width,nk) if(file.modify) then line(nk+1:) = '/MOD' width = width + 4 else line(nk+1:) = ' ' endif kar = ' ' if(p_file .eq. control.cur_file) kar = '*' call sys$fao('!AS !#AS !AS !AS !#UL',nk,hline, 1 kar, 1 %val(nk_h), 1 file.handle//' ',ftyp(1:7), 1 line(1:width), 1 %val(nk_s),%val(file.filesize)) if(.not. dix_dump_print_line(control,0,hline(1:nk))) goto 90 c if(full) then call dix_rms_file_info(control,file) endif c c check if descriptors too c if(do_descr) then p_des_expanded = file.top_des do while(p_des_expanded .ne. 0) kar = ' ' if(file.cur_des .eq. p_des_expanded) kar = '*' p_des_info = des_expanded.p_des_info ftyp = 'Descr' call dix_des_display(control,des_info,line,nk,.true.) if(des_expanded.is_expanded) then call sys$fao('!#UL',nk1,countasc, 1 %val(nk_s),%val(des_expanded.table_nor.count+ 1 des_expanded.table_vfc.count)) else countasc = ' ' countasc(nk_s-1:nk_s) = 'NE' endif call sys$fao(' !AS!AS !AS !AS !AS',nk,hline, 1 kar,' '//des_expanded.handle(1:nk_h-1),ftyp(1:7), 1 line(1:width),countasc(1:nk1)) if(.not. dix_dump_print_line(control,0,hline(1:nk))) goto 90 p_des_expanded = des_expanded.link.forw enddo end if end do call sys$fao('* means the current file',nk,hline) if(do_descr) then call sys$fao(' or description, NE is not expanded (yet)', 1 k,hline(nk+1:)) nk = nk + k endif if(.not. dix_dump_print_line(control,0,hline(1:nk))) goto 90 c 90 return end function dix_dump_inter_sel_file(control,is_term,mask,err_arg) implicit none c c LEt the user select a file from the file list c the match is the fiorst file that matches c include 'dix_def.inc' record /control/ control !:i: control structure logical*4 is_term !:i: inter mode character*(*) mask !:i: file mask character*(*) err_arg !:o: error argument integer*4 dix_dump_inter_sel_file !:f: Function result c# record /file_info/ file pointer (p_file,file) c c character*(max_line_length) line,tline character kar integer*4 k,nam_width,nk,i_fil,max_width,istat,save_ptr,ptr_file integer*4 n_fnd,tag_width c logical*4 dix_util_get_nr integer*4 dix_dump_print_line integer*4 dix_dump_inter_next_file c external dix_msg_nofilmat c istat = 1 c c First see how many match c first get the max length of the tag and count them c save_ptr = 0 c ptr_file = 0 n_fnd = 0 tag_width = 0 c do while(dix_dump_inter_next_file(control,ptr_file,mask, 1 wildcard_flag_standard)) c p_file = ptr_file c c Format the long way c tag_width = max(file.nk_handle,tag_width) n_fnd = n_fnd + 1 save_ptr = ptr_file end do c c Pick the special cases c 0 : notfound c 1 : Unique match, use it c if(n_fnd .eq. 0) then istat = %loc(dix_msg_nofilmat) err_arg = mask goto 90 elseif(n_fnd .eq. 1) then control.cur_file = save_ptr goto 90 endif c c Now we know the width needed for the tag c the line printed is c *nnnn:tag name ssssss c so the remaining size is width-6-tagwidth-1-1-6 c max_width = control.ncols - 6 - tag_width - 8 nam_width = 0 c ptr_file = 0 do while(dix_dump_inter_next_file(control,ptr_file,mask, 1 wildcard_flag_standard)) c p_file = ptr_file c c Format the long way c line = file.fnam(1:file.nk_fnam) call lib$trim_filespec(file.fnam(1:file.nk_fnam),line,max_width,nk) nam_width = max(nk,nam_width) end do c c We have more than 1 match, display them c Print header c call sys$fao(' Indx:!#AS !#AS Size',nk,tline, 1 %val(tag_width),%descr('Tag'), 1 %val(nam_width),%descr('Name')) if(.not. dix_dump_print_line(control,0,tline(1:nk))) goto 90 c k = 0 i_fil = 0 ptr_file = 0 do while(dix_dump_inter_next_file(control,ptr_file,mask, 1 wildcard_flag_standard)) p_file = ptr_file kar = ' ' k = k + 1 if(p_file .eq. control.cur_file) then i_fil = k kar = '*' endif call lib$trim_filespec(file.fnam(1:file.nk_fnam),line,max_width,nk) c call sys$fao('!AS!4UL:!AS !AS !6UL',nk,tline, 1 kar,%val(k), 1 file.handle(1:tag_width), 1 line(1:nam_width), 1 %val(file.filesize)) if(.not. dix_dump_print_line(control,0,tline(1:nk))) goto 90 end do c c Check if at at a terminal, if not exit now c if(is_term) then if(dix_util_get_nr(k,i_fil)) then ptr_file = 0 do k=1,i_fil call dix_dump_inter_next_file(control,ptr_file,mask, 1 wildcard_flag_standard) end do control.cur_file = ptr_file endif endif c 90 dix_dump_inter_sel_file = istat return end function dix_dump_inter_get_file(control,field,ptr_file,err_arg) implicit none c c Select a file by tag (or take current) c include 'dix_def.inc' record /control/ control !:i: control structure character*(*) field !:i: cli token integer*4 ptr_file !:o: pointer to file structure character*(*) err_arg !:o: errorargument integer*4 dix_dump_inter_get_file c# integer*4 istat,wild_flag,nk_tag character*(max_symbol_name_length) tag c external dix_msg_filnotf integer*4 dix_dump_inter_next_file call cli$get_value(field,tag,nk_tag) c wild_flag = wildcard_flag_none c c Take the first (equal match) c ptr_file = 0 istat = dix_dump_inter_next_file(control,ptr_file, 1 tag(1:nk_tag),wild_flag) if(.not. istat) then istat = %loc(dix_msg_filnotf) err_arg = tag else istat = 1 endif dix_dump_inter_get_file = istat return end c function dix_dump_i_get_keys(file,control,err_arg,trans) c implicit none cc cc display RMS-key info cc c include 'dix_def.inc' c record /file_info/ file !:i: file c record /control/ control !:i: control block c character*(*) err_arg !:o: error argument c logical trans !:i: c integer*4 dix_dump_i_get_keys !:f: function result cc# c integer*4 key1,istat,nk,ios c logical*4 string,ascending,got_one c integer*4 length c character*(max_rms_key_name_length) keynam c character*(max_line_length) line cc c logical*4 dix_rms_keyinfo c logical*4 cli$get_value c logical*4 cli$present c integer*4 dix_main_get_keyvals c integer*4 dix_con_int_ascint c integer*4 dix_rms_get_rfa cc c record /rfa/ rfa cc c external dix_msg_illkey c external dix_msg_notindex cc cc First see if /rfa is given cc c if(cli$present('rfa')) then cc cc Get first part (block/bucket number) cc c call cli$get_value('rfa',line,nk) c istat = dix_con_int_ascint(line(1:nk),rfa.bbnr,32,' ', c 1 0,0,control,.false.) c if(.not. istat) goto 90 cc cc Get second part offset cc c call cli$get_value('rfa',line,nk) c istat = dix_con_int_ascint(line(1:nk),rfa.offset,16,' ', c 1 0,0,control,.false.) c if(.not. istat) goto 90 cc c call cli$get_value('KEY',line,nk) c if(nk .gt. 0) then c read(line(1:nk),2000,iostat=ios) key1 cc2000 format(bn,i10) c if(.not. dix_rms_keyinfo(file,key1,string,length, c 1 ascending,keynam)) then c istat = %loc(dix_msg_illkey) c goto 90 c endif c else c key1 = file.cur_key c endif c istat = dix_rms_get_rfa(control,file,key1,rfa) c else cc cc c istat = dix_main_get_keyvals(control,file, c 1 got_one,trans,.false.,err_arg) c endif c90 dix_dump_i_get_keys = istat c return c end subroutine dix_dump_get_err_lab(control,file_level) implicit none c c process a /err= c include 'dix_interactive.inc' record /control/ control !:i: control block record /file_level/ file_level !:i: file level c# call dix_dump_get_erreof(control,file_level, 1 'ERROR',control.error_label) return end subroutine dix_dump_get_eof_lab(control,file_level) implicit none c c Process a /end= flag c include 'dix_interactive.inc' record /control/ control !:i: control block record /file_level/ file_level !:i: file level c# call dix_dump_get_erreof(control,file_level,'END',control.eof_label) return end subroutine dix_dump_get_erreof(control,file_level,what,label) implicit none c c Set the /error, and the /end= option c include 'dix_interactive.inc' record /control/ control !:io: control structure record /file_level/ file_level !:i: command file level character*(*) what !:i: what to set character*(*) label !:o: the label field c# external dix_msg_ignoterm c call cli$get_value(what,label) if(label .ne. ' ') then if(file_level.is_term) then call dix_message(control,dix_msg_ignoterm,what) label = ' ' endif endif return end subroutine dix_dump_inter_show_vm(control,fi) implicit none c c Display vm info for command levels c include 'dix_interactive.inc' record /control/ control !:i: control block logical fi !:i: full flag c# record /file_level/ file_level pointer (p_file_level,file_level) c p_file_level = control.top_level do while (p_file_level .ne. 0) call dix_util_show_vm1(control,file_level.zone_level,fi,1) p_file_level = file_level.link.forw end do return end function dix_inter_execute(control,what,lun,bitsize,fields,ink,idata, 1 onk,odata,obitsize) implicit none c include 'dix_interactive.inc' record /control/ control !:i: control structure character*(*) what integer*4 lun !:i: lun with data integer*4 bitsize !:i: size in bits of data character*(*) fields !:i: field values integer*4 ink !:i: size in bytes of data byte idata(*) integer*4 onk !:o: output string length byte odata(*) !:o: output data integer*4 obitsize integer*4 dix_inter_execute c# record /file_level/ file_level pointer (p_file_level,file_level) record /dis_pars/ dis record /value/ val c integer*4 istat,descr(2),iterm character*(max_line_length) line c integer*4 dix_inter_create_new_level logical dix_symbol_find integer*4 dix_dump_interactive c external dix_msg_varwrtype external dix_msg_varnotf c istat = dix_inter_create_new_level(control) if(istat) then p_file_level = control.cur_level call dix_inter_set_default_error(file_level) call memtab_rewind(lun) file_level.lun = lun file_level.is_call = .false. file_level.output_opened = .false. file_level.verify = 1 (control.debug .and. debug_command) .ne. 0 file_level.nk_file = 0 file_level.filename = ' ' file_level.lun_out = control.lun_out c call dix_symbol_add_str(control,'ACTION',what,line) c descr(1) = ink descr(2) = %loc(idata) c call dix_symbol_add_str(control,'DATA',descr,line) c call dix_symbol_add_str(control,'FIELDS',fields,line) c if(bitsize .ne. 0) then call dix_symbol_add_int(control,'BITSIZE',bitsize,line) endif c istat = dix_dump_interactive(control,iterm,dis,.true.) if(istat) then c c Now get the data from the symbols c for SIZE : size c for BINASC : result c for ascbin : size and result c c call dix_eval_init_value(val) c if(what .eq. 'SIZE' .or. what .eq. 'ASCBIN') then if(dix_symbol_find(control,'SIZE',val)) then if(val.type .eq. symb_typ_int) then call lib$movc3(ONK,val.ival,obitsize) else call dix_message(control,dix_msg_varwrtype, 1 %DESCR('SIZE')) endif else call dix_message(control,dix_msg_varnotf,'SIZE') endif endif if(what .eq. 'BINASC' .or. what .eq. 'ASCBIN') then if(dix_symbol_find(control,'RESULT',val)) then if(val.type .eq. symb_typ_char) then onk = zext(val.strdes.dsc$w_maxstrlen) call lib$movc3(onk,%val(val.strdes.dsc$a_pointer),odata) else call dix_message(control,dix_msg_varwrtype, 1 %DESCR('RESULT')) endif else call dix_message(control,dix_msg_varnotf,%DESCR('RESULT')) endif endif !found required symbol call dix_eval_free_value(val) endif !dix_dump_inter is oke call dix_inter_close_level(control,.false.) endif dix_inter_execute = istat return end function dix_dump_i_wrfile(fnam,append,nb_data,data) implicit none c c Writ a record to a data file or append c include 'dix_size_def.inc' character*(*) fnam !:i: the filename logical*4 append !:i: append to existing file integer*4 nb_data !:i: #bytes byte data(nb_data) !:i: the data integer*4 dix_dump_i_wrfile !:f: the result c integer*4 istat,lun,ios character*(max_short_line_length) access,status c call lib$get_lun(lun) if(append) then status = 'OLD' access = 'APPEND' else status = 'NEW' access = 'SEQUENTIAL' endif open(lun, 1 file =fnam, 1 status =status, 1 access =access, 1 err =80, 1 form ='unformatted', 1 recordtype ='variable', 1 iostat = ios) c if(ios .ne. 0) goto 80 write(lun,err=60,iostat=ios) data if(ios .ne. 0) goto 60 istat = 1 goto 65 c c Write error c 60 call errsns(,istat) c 65 close(lun) goto 90 c c OPen error c 80 call errsns(,istat) c 90 call lib$free_lun(lun) dix_dump_i_wrfile = istat return end function dix_inter_set_file(control,err_arg) implicit none c c Set file characteristics c include 'dix_def.inc' record /control/ control !:i: control block character*(*) err_arg !:o: error argument c integer*4 dix_inter_set_file c c set file [mask]/qualifiers c character*(max_filename_length) mask logical*4 flag integer*4 nk_m,istat,ptr_file,wild_flag c c external dix_msg_nofilmat logical*4 dix_util_set_flag c record /file_info/ file pointer (p_file,file) c integer*4 dix_dump_inter_next_file integer*4 dix_rms_change_modify c c Get mask c call cli$get_value('p2',mask,nk_m) call dix_dump_inter_set_wild(wild_flag,wildcard_flag_standard) err_arg = mask(1:nk_m) istat = %loc(dix_msg_nofilmat) c ptr_file = 0 c do while(dix_dump_inter_next_file(control,ptr_file, 1 mask(1:nk_m),wild_flag)) p_file = ptr_file c c Now we have the file present c call dix_util_set_flag('locking.rrl',file.rrl) call dix_util_set_flag('locking.optimistic',file.oplock) c istat = cli$present('modify') if(dix_util_set_flag('modify',flag)) then istat = dix_rms_change_modify(control,file,flag) if(.not. istat) call dix_message(control,%val(istat)) endif cc if(istat .eq. cli$_negated) then c istat = dix_rms_change_modify(control,file,.false.) c elseif(istat .eq. cli$_present) then c istat = dix_rms_change_modify(control,file,.true.) c endif istat = 1 enddo c dix_inter_set_file = istat return end function dix_dump_inter_next_file(control,ptr_file,mask,wild_flag) implicit none c c Get the next file matching mask c init ptr_file to 0, and keep calling this routine c include 'dix_def.inc' c record /control/ control !:i: control block integer*4 ptr_file !:io:pointer to file character*(*) mask !:i: mask for filename/tag integer*4 wild_flag !:i: wildcard? logical dix_dump_inter_next_file !:f: true if file present c# record /file_info/ file pointer (p_file,file) c logical*4 mask_empty logical*4 dix_dump_inter_match_file c mask_empty = mask .eq. ' ' c if(ptr_file .eq. 0) then if(mask_empty) then p_file = control.cur_file !take current file else p_file = control.top_file !take top file endif else if(mask_empty) then p_file = 0 !all done (only current) else p_file = ptr_file !take next file p_file = file.link.forw endif endif c c Now check for mask c if(.not. mask_empty) then 20 if(p_file .ne. 0) then if(dix_dump_inter_match_file(file,mask,wild_flag)) goto 90 c c No match, try the next c p_file = file.link.forw goto 20 endif endif 90 ptr_file = p_file dix_dump_inter_next_file = ptr_file .ne. 0 return end function dix_dump_inter_match_file(file,mask,wild_flag) implicit none c c Match the next file c See if the file handle/name matches to mask c include 'dix_def.inc' record /file_info/ file !:I: the filename character*(*) mask !:i: mask integer*4 wild_flag !:i: style matching c# logical*4 dix_dump_inter_match_file c integer*4 nk logical*4 status c logical*4 dix_util_match_string_wild c status = .true. c c First match on handle c nk = file.nk_handle if(dix_util_match_string_wild(file.handle(1:nk), 1 mask,.false.,wild_flag)) goto 90 c c If that does not match, try the filename c nk = file.nk_fnam if(dix_util_match_string_wild(file.fnam(1:nk), 1 mask,.false.,wild_flag)) goto 90 c c Still no match c status = .false. c 90 dix_dump_inter_match_file = status return end function dix_dump_inter_next_descr(file,ptr_descr,mask, 1 wild_flag,allow_one) implicit none c c Get the next description matching mask c init ptr_file to -1, and keep calling this routine c include 'dix_def.inc' c record /file_info/ file !:i: control block integer*4 ptr_descr !:io:pointer to descr character*(*) mask !:i: mask for filename/tag integer*4 wild_flag !:i: wildcard? logical*4 allow_one !:i: allow the current = 0? logical dix_dump_inter_next_descr !:f: true if file present c# record /des_expanded/ des_expanded pointer (p_des_expanded,des_expanded) c logical*4 mask_empty logical*4 dix_dump_inter_match_des c mask_empty = mask .eq. ' ' c if(ptr_descr .eq. -1) then c c First time c if(mask_empty) then p_des_expanded = file.cur_des !take current file else p_des_expanded = file.top_des !take top file endif else c c not the first time, take the next, unless mask_empty , -> exit c if(mask_empty) then p_des_expanded = 0 !all done (only current) else p_des_expanded = ptr_descr !take next file p_des_expanded = des_expanded.link.forw endif endif c c Now check for mask c if(.not. mask_empty) then 20 if(p_des_expanded .ne. 0) then if(dix_dump_inter_match_des(des_expanded,mask, 1 wild_flag)) goto 90 c c No match, try the next c p_des_expanded = des_expanded.link.forw goto 20 endif endif 90 if(mask_empty .and. allow_one) then c c If no mask, the first query (even if it returns zero) is always oke c this allows for examining in raw mode c dix_dump_inter_next_descr = ptr_descr .eq. -1 else dix_dump_inter_next_descr = p_des_expanded .ne. 0 endif ptr_descr = p_des_expanded return end function dix_dump_inter_match_des(des_expanded,mask,wild_flag) implicit none c c See if the des matches "mask" c include 'dix_def.inc' record /des_expanded/ des_expanded !:i: the expand sttructure character*(*) mask !:i: mask to match integer*4 wild_flag !:i: wildcrad match? logical*4 dix_dump_inter_match_des !:f: true ios fatch c# record /des_info/ des_info pointer (p_des_info,des_info) c logical*4 status integer*4 nk logical*4 dix_util_match_string_wild c status = .true. nk = des_expanded.nk_handle c c First try the handle c if(dix_util_match_string_wild(des_expanded.handle(1:nk), 1 mask,.false.,wild_flag)) goto 90 c p_des_info = des_expanded.p_Des_info nk = des_info.nk_fnam c c Now try the filename c if(dix_util_match_string_wild(des_info.fnam(1:nk), 1 mask,.false.,wild_flag)) goto 90 status = .false. 90 dix_dump_inter_match_des = status return end function dix_dump_i_dcl_parse_table(file_level,line,nk,quiet) implicit none c include 'dix_interactive.inc' record /file_level/ file_level character*(*) line integer*4 nk logical*4 quiet integer*4 dix_dump_i_dcl_parse_table c integer*4 istat c integer*4 nk_extra character*(max_command_length) line_extra common /common_my_get_input/ nk_extra,line_extra c integer*4 dix_dcl_parse_table_int external my_get_input integer*4 my_get_input c nk_extra = 0 istat = dix_dcl_parse_table_int(line(1:nk),my_get_input,quiet) c if(istat) then if(file_level.is_term) then if(nk_extra .gt. 0) then line(nk+1:) = line_extra(1:nk_extra) nk = nk + nk_extra call smg$replace_input_line(file_level.lun,line(1:nk)) end if endif endif dix_dump_i_dcl_parse_table = istat return end function dix_dump_int_show_rel(control,err_arg,file_Level,dis) implicit none c c View the realease notes c include 'dix_interactive.inc' record /control/ control character*(*) err_arg record /file_level/ file_level record /dis_pars/ dis integer*4 dix_dump_int_show_rel c include '($jpidef)' c character*(max_filename_length) imagname character*(max_line_length) line character*(max_short_line_length) version integer*4 nk_imag,lun,istat,nk c character*(*) relnotes_file parameter (relnotes_file = 'release_notes.txt') integer*4 save_lun,save_paged,iver,iver1,nk1 logical skip c logical*4 cli$present external dix_msg_filnotop integer*4 dix_dump_i_open_output integer*4 dix_util_conv_version_ascint integer*4 dix_dump_print_line c call lib$getjpi(jpi$_imagname,,,,imagname,nk_imag) c skip = .false. !assume not skip iver = 0 !no version found c if(cli$present('version')) then skip = .true. call cli$get_value('version',version,nk) if(version .ne. ' ') then err_arg = version(1:nk) istat = dix_util_conv_version_ascint(version(1:nk),iver) if(.not. istat) goto 99 else iver = -1 !signal special (version only) endif end if c c Try to open the output file c istat = dix_dump_i_open_output(control,save_lun,save_paged, 1 err_arg,dis.is_term,file_level) c if(istat) then c c Open out is oke, now get the relnotes c call lib$get_lun(lun) open(lun,file=relnotes_file//';0', 1 status='old', 1 defaultfile=imagname(1:nk_imag), 1 shared,readonly,err=80) 10 read(lun,2000,end=20) nk,line 2000 format(q,a) if(line(1:1) .eq. 'V') then read(line(2:5) ,2010,err=15) iver1 2010 format(i4) if(iver .le. 0 .or. iver .eq. iver1) then c c Display version number c if(iver1 .lt. 9999) then call dix_util_conv_version_intasc(iver1,version,nk1) if(.not. dix_dump_print_line(control,0,'Version '// 1 version(1:nk1)//' of '//line(7:nk))) goto 20 endif endif if(iver .gt. 0) then c c We have a version, see if asked for a specific version c if(iver1 .gt. iver) goto 20 if(iver1 .eq. iver) skip = .false. endif goto 10 endif 15 if(.not. skip) then if(.not. dix_dump_print_line(control,0,line(1:nk))) goto 20 endif goto 10 c 20 close(lun) goto 90 80 istat = %loc(dix_msg_filnotop) err_arg = relnotes_file c 90 call lib$free_lun(lun) c call dix_dump_i_close_output(control,save_lun, 1 save_paged,file_level, 1 'Release notes') endif c 99 dix_dump_int_show_rel = istat return end subroutine dix_inter_set_hex_mode(hex_flag) implicit none c include 'dix_def.inc' integer*4 hex_flag c logical*4 cli$present c if(cli$present('decimal')) hex_flag= des_flag_translate_nor if(cli$present('hex')) hex_flag= des_flag_translate_hex if(cli$present('octal')) hex_flag= des_flag_translate_oct if(cli$present('binary')) hex_flag= des_flag_translate_bin return end subroutine dix_dump_inter_set_wild(wild_flag,default_flag) implicit none c include 'dix_def.inc' c c Set the wildcard flag c integer*4 wild_flag integer*4 default_flag c integer*4 ignore_message external ignore_message c integer*4 cli$present c wild_flag = default_flag c if(cli$present('wildcard.none')) 1 wild_flag = wildcard_flag_none if(cli$present('wildcard.standard')) 1 wild_flag = wildcard_flag_standard if(cli$present('wildcard.extended')) 1 wild_flag = wildcard_flag_extended c c For compatibitlity check fot the /unix qualifier c set the ignore to ignore the signalling c call lib$establish(ignore_message) if(cli$present('unix')) wild_flag = wildcard_flag_extended return end subroutine dix_inter_conv_strict(strict_mode,line,nk) implicit none c cConverrt strict to text c include 'dix_def.inc' integer*4 strict_mode !:i: strict mode character*(*) line !:o: the text integer*4 nk !:o: length c nk = 0 if(iand(strict_mode,strict_typing) .ne. 0) then call dix_append(nk,line,'/TYPING') else call dix_append(nk,line,'/NOTYPING') endif if(iand(strict_mode,strict_declaration) .ne. 0) then call dix_append(nk,line,'/DECLARATIONS') if(iand(strict_mode,strict_declaration_local).ne.0)then call dix_append(nk,line,'/LOCAL') else call dix_append(nk,line,'/NOLOCAL') endif else call dix_append(nk,line,'/NODECLARATIONS') endif return end function dix_inter_set_ver(control,new_value) implicit none c c Set new verity level (and return old one) c include 'dix_interactive.inc' record /control/ control !:i: control block logical*4 new_value !:i:-1 (do not change, 0=clear, 1=set) logical*4 dix_inter_set_ver !:f: old value c record /file_level/ file_level pointer (p_file_level,file_level) c p_file_level = control.cur_level c dix_inter_set_ver = file_level.verify if(new_value .ge. 0) file_level.verify = new_value .eq. 1 return end