! Rick Stacks' TPU initilization routine for DEBUGging TPU procedures ! Page 1 ! COPYRIGHT © 1983, 1984, 1985 BY ! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASSACHUSETTS ! ALL RIGHTS RESERVED ! ! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED ! ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE ! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER ! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY ! OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY ! TRANSFERRED. ! ! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE ! AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT ! CORPORATION. ! ! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL. ! ! !++ ! FACILITY: ! Text Processing Utility (VAXTPU) ! ! ABSTRACT: ! This is the VAXTPU source program for the VAXTPU debugger ! ! ENVIRONMENT: ! VAX/VMS ! !Authors: Sharon Burlingame, Steve Long, Terrell Mitchell ! ! CREATION DATE: 1-DEC-1983 ! ! MODIFIED BY: ! ! V01-000 New Copyright Notice and Version Number smb 08-May-85 !+ ! DEBUG.TPU ! ! Table of Contents as of 17-Mar-1985 ! ! Procedure name Page Description ! -------------- ---- ------------ ! ! debugon 1 ! dbg$_debug 2 ! dbg$debug_lookup_global_name 6 ! dbg$build_name_lists 7 ! dbg$remove_comments 8 ! dbg$debug_lookup_scoped_name 9 ! ! ! example of a user-written debugger ! ! debugger has 5 basic commands(all single chr commands) ! ! s - single step to next line ! g - go to next breakpoint(or stop debugging if no more breakpoints) ! h - help ! e - examine followed by name ! X - EXECUTE TPU COMMAND ! ! - a return key typed to the prompt will do a single step command('s') !NOTE: Users are encouraged to modify the following procedure PROCEDURE DEBUGON(TARGET_PROCEDURE) local dbg$name, target_procedure, temp; dbg$last_procedure_name:=''; ! keeps name of active procedure being debugged dbg$local_list:=''; ! local name list dbg$param_list:=''; ! parameter name list dbg$screen_line:=1; ! change this if the first line of the debug window ! is desired to be other than the top line dbg$screen_size:=6; ! change this if the size of the debug window ! needs to be different dbg$sstep_key:=ret_key; ! default key to do a single step command('s') IF GET_INFO(debug_buffer,"type")=buffer THEN DELETE(DEBUG_BUFFER); ! get rid of the old debug buffer contents ENDIF; if target_procedure <> "" then dbg$name := target_procedure; else dbg$name := read_line("Name of procedure to debug: "); endif; if dbg$name <> "" then set(debug, on, dbg$name); endif; ENDPROCEDURE; ! Page 2 ! main procedure, called from TPU if a SET(DEBUG,ON,PROGRAM,'dbg$_debug'); ! has been done ! !NOTE: Users are NOT encouraged to modify the following procedure ! do so at your own risk ! procedure dbg$_debug LOCAL name_exists, tmp_val, scoped_number, data_type, list_name, xfile_name, file_name, tmp_count, p1, p2, t1, r1, first_chr, var_name, input_cmd, type_string, display_type, display_value, type_index, save_current_position, next_window; type_string:="UNKNOWN INTEGER STRING MARKER RANGE "+ "BUFFER WINDOW PATTERN PROGRAM PROCESS "+ "LEARN "; !+ ! check to see if debug_buffer exists ! if not prompt for name of file that contains code to be debugged ! and read it into the command_buffer ! ! create a window,debug_window, if not there and map the window to the buffer ! highlight the line of text to be executed ! thn prompt for a command: ! ! !- save_current_position:=mark(none); ! save place to reposition to later !+ ! check if debug_buffer exists,if not prompt and create it !- IF GET_INFO(debug_buffer,"type")<> buffer THEN ! create a debug buffer debug_buffer:=create_buffer('DEBUG'); set(system,debug_buffer); set(no_write,debug_buffer); temp_buffer:=current_buffer; position(debug_buffer); loop xfile_name:=read_line("Need source(file spec or ):"); if xfile_name <> '' then file_name:=read_file(xfile_name); exitif else message( 'No file specified,source is in current buffer'); COPY_TEXT(temp_buffer); exitif; endif; endloop; ENDIF; !+ ! check if debug_window exists !- IF GET_INFO(debug_window,"type") <> window THEN !create a debug_window debug_window:=create_window(dbg$screen_line,dbg$screen_size,off); set(status_line,debug_window,reverse,"DEBUG WINDOW: "); ENDIF; !+ !update all visible windows !- next_window:=get_info(window,"first"); LOOP exitif next_window=0; if get_info(next_window,"visible") THEN update(next_window); endif; next_window:=get_info(window,"next"); ENDLOOP; position(beginning_of(debug_buffer)); !+ ! highlight the line at which the breakpoint is at with -> pointing to line !- p1:=0; if mark(none) <> end_of(debug_buffer) then ! ok,source file exists move_vertical(debug_line-1); ! move to the line p1:=mark(none); copy_text("->"); if debug_line <> 1 ! if not on first line,move back to show more context then move_vertical(-1); endif; else ! at eob,probably empty buffer message('no source line exists for line '+str(debug_line)); endif; map(debug_window,debug_buffer); update(debug_window); dbg$build_name_lists; ! build local and param name lists for EXAMINE command to use !+ ! now read a command !- ! if command buffer and window do not exist,create them if get_info(debug_command_buffer,"type") <> buffer then ! create a prompt area debug_command_buffer:=create_buffer('DEBUG_COMMANDS'); set(system,debug_command_buffer); set(no_write,debug_command_buffer); debug_command_window:=create_window(dbg$screen_line+dbg$screen_size,1,off); endif; map(debug_command_window,debug_command_buffer); position(beginning_of(debug_command_buffer)); erase(debug_command_buffer); copy_text('DEBUG>'); update(debug_command_window); ! make it appear ! Page 3 !+ ! read debugger commands until G or s typed !- loop erase(debug_command_buffer); copy_text('TPUDEBUG>'); update(debug_command_window); ! make it appear input_cmd:=read_key; !echo chracter typed if input_cmd = dbg$sstep_key then ! pretend it was an 's' comand first_chr:='s'; else copy_text(ascii(input_cmd)); first_chr:=ascii(input_cmd); endif; !+ ! make it appear in the window !- update(debug_command_window); change_case(first_chr,lower); ! Page 4 ! known commands: ! ! e var ! Examine variable name ! s ! single step proceed ! g ! proceed to next breakpoint ! x xyz command ! execute xyz command ! h ! help ! ! Page 5 !+ ! loop here reading in debugger commands !- CASE first_chr FROM 'e' TO 'x' ['e','x']: ! EXAMINE or EXECUTE var_name:=''; copy_text(' '); update(debug_command_window); ! read the name of the variable loop input_cmd:=read_key; if input_cmd = ret_key then exitif else if input_cmd=del_key then var_name:=substr(var_name,1,length(var_name)-1); if var_name='' then erase(debug_command_buffer); exitif; ! treat as a control u endif; erase_character(-1); update(debug_command_window); else if input_cmd=ctrl_u_key then erase(debug_command_buffer); exitif; var_name:=''; else ! regular key hopefully copy_text(ascii(input_cmd)); update(debug_command_window); var_name:=var_name+ascii(input_cmd); endif; endif; endif; endloop; !+ ! now got the variable name or command !- if var_name <> '' then if first_chr = 'x' ! EXECUTE COMMAND then ! execute command typed p1:=mark(none); ! current_position position(save_current_position); ! execute the command in the correct context so ! a current_line(for example) command will work execute(var_name); position(p1); else ! command was 'e' ! EXAMINE command ! see if name is a local or parameter name EDIT(vaR_NAME,trim_leading,trim_trailing,upper); dbg$debug_tmp:=0; ! reset scoped_number:= dbg$debug_lookup_scoped_name(var_name+" ",list_name); if scoped_number = 0 ! not a local or parameter ! see if a global name then name_exists:=dbg$debug_lookup_global_name(var_name); if name_exists then ! a global , get value execute('dbg$debug_tmp:='+var_name); endif else ! it is a local or parameter ! get the correct parameter contents local_val:=get_info(debug,list_name ); tmp_count:=1; loop exitif tmp_count = scoped_number; local_val:=get_info(debug,"next"); tmp_count:=tmp_count+1; endloop; name_exists:=1; ! set for below dbg$debug_tmp:=local_val; endif; if name_exists then display_value:=''; data_type:= get_info(dbg$debug_tmp,"type"); type_index:=11*data_type; if type_index=0 then type_index:=1 endif; ! display just the name and the type CASE data_type from unspecified to LEARN [integer]: display_value:=str(dbg$debug_tmp) [string]: display_value:=dbg$debug_tmp; [marker]: t1:=mark(none); position(dbg$debug_tmp); display_value:=current_character; position(t1); [range]: display_value:=substr(dbg$debug_tmp,1,40) ; [buffer]: display_value:="buffer name: "+ get_info(dbg$debug_tmp,"name"); [window]: display_value:="top line : "+ str(get_info(dbg$debug_tmp,"original_top")) + ",bottom line: "+ str(get_info(dbg$debug_tmp, "original_bottom")); [process]: display_info:="PID="+str(get_info (dbg$debug_tmp, "PID")); [inrange,outrange]: display_value:="? "; endcase; display_value:=display_value+",type="+ substr(type_string,type_index,11); ! update the status line set(status_line,debug_window,reverse,"DEBUG WINDOW: "+ var_name+"="+display_value); update(debug_window); endif; endif; endif; ['s']: !SINGLE STEP exitif; ! it defaults to single step unless told to do so ['g']: !GO set(debug,off); ! explicity turn off single step mode exitif; ['h']: !help erase(debug_command_buffer); set(status_line,debug_window,reverse, "H - Help , E name - Examine variable ,S-single step,G- GO"+ ", X cmd - Execute cmd"); update(debug_window); ! end of debug read chr loop [inrange,outrange]: !unknown command set(status_line,debug_window,reverse,"DEBUG WINDOW: "+ "Unrecognized command"); update(debug_window); ENDCASE; endloop; !s ,g,or e typed,causing the rea chr loop to terminate ! get rid of "->" if p1 <> 0 then position(p1); erase_character(-2); endif; ! restore state unmap(debug_command_window); unmap(debug_window); position(save_current_position); endprocedure ! Page 6 ! + ! Two utility procedures used by the Examine command. ! one to look up a variable and see if it is a global name,the ! other procedure is used to see if the variable name is a local variable ! or parameter name ! - procedure dbg$debug_lookup_global_name(id) local j; on_error ! SILENCE ERRORS endon_error J:=expand_name(id,variables) ; if j <> '' then change_case(ID,upper); IF( ID= J) OR ! non-unique ( index(j+" ",id+" ") <> 0) then return 1 else message('variable name not unique,list of possible names:'); message(j); return 0 endif else ! not found MESSAGE('UNKNOWN variable name -> '+id); return 0 endif; endprocedure ! Page 7 procedure dbg$build_name_lists ! local local_range, trail_semi, last_procedure_name, local_match, match_procedure, saved_position, temp, proc_beg, proc_end ; ! called from the EXAMINE command ! + ! Construct a local name list and parameter name list ONCE per procedure ! invocation. These two lists will be used by the EXamine command to ! display contents of local variables and passed parameters ! - ! ! try to match PROCEDURE name ( ! if matched, then the parameter list and local list will ! be saved for future examine commands in two global variables ! (no trailing comments on the locals for now) ! dbg$param_list ! db$$local_list ! ! on_error if mark(none) = end_of(current_buffer) then position(saved_position); return endif; endon_error; ! silence error messages saved_position:=mark(none); ! backup to procedure stmt ! first determine if the procedure has changed from last time ! (this saves rebuilding the name lists) last_procedure_name:=search("PROCEDURE",reverse); if last_procedure_name = 0 then return else position(last_procedure_name); if current_line = dbg$last_procedure_name then position(saved_position);return ! name lists are already built else temp:=current_line; edit(temp,trim_leading,UPPER); if substr(temp,1,1) <> 'P' then position(saved_position);return endif; endif; endif; !save for next time dbg$last_procedure_name:=current_line; move_horizontal(-current_offset); ! pattern for LOCAL stmt trail_semi:=";" &''; local_match:=anchor &"LOCAL"&trail_semi; !pattern for PROCEDURE stmt match_procedure:=anchor & (span(' ')|line_begin) &"PROCEDURE" & SCAN('('); proc_beg:=search(match_procedure,forward) ; if proc_beg <> 0 then ! on a procedure statement dbg$param_list:=''; dbg$local_list:=''; ! extract list of parameters position(end_of(proc_beg)); move_horizontal(2) ; ! move past "(" proc_end:=search(")",forward); dbg$param_list:=" "+substr( create_range(mark(none), end_of(proc_end), none), 1,999); ! got list of parameter nanes in format x,y,z) translate(dbg$param_list," ",",)"); change_case(dbg$param_list,upper); ! got list in form x y z dbg$param_list:=dbg$param_list+" "; ! add trailing blank else ! no passed parameters dbg$param_list:=""; endif; ! match LOCAL namelist ; if proc_beg <> 0 then position(end_of(proc_end)) endif; move_horizontal(-current_offset); loop move_vertical(1); if current_line <> "" then if current_character <> "!" then exitif endif endif; endloop; ! get on LOCAL stmt if current_character ="-" then ! I'm sitting on the -> in front of the LOcal move_horizontal(2) endif; ! search for LOCAL stmt on current line local_range:=search(local_match,forward); if local_range = 0 then position(saved_position); return endif; dbg$local_list:=substr(local_range,1,999); if index(dbg$local_list,"!") <> 0 then ! THE LOCAL stmt has comments in it! message("Removing comments inside of the LOCAL stmt"); dbg$local_list:=dbg$remove_comments(local_range); ! get rid of them endif; dbg$local_list:=substr(dbg$local_list,6,999); ! get rid of local translate(dbg$local_list," ",",;"); edit(dbg$local_list,compress,upper); dbg$local_list:=dbg$local_list+" "; ! all done . Local name list is in the form x y z position(saved_position); endprocedure ! Page 8 ! get rid of commented local variables in the local statement procedure dbg$remove_comments(local_range) local comment_pattern, local_list, new_range, comment_range; on_error endon_error; local_list:=''; comment_pattern:=ANY("!")&REMAIN; position(local_range); loop comment_range:=search(comment_pattern,forward); if (comment_range = 0 ) then exitif else ! found a comment , remove it if ( beginning_of(comment_range) <= end_of(local_range) ) then position(comment_range); erase(comment_range); else exitif ! outside of range,all done endif; endif; endloop; ! all done local_list:=substr(local_range,1,9999); return local_list; endprocedure ! Page 9 procedure dbg$debug_lookup_scoped_name(variable_name,list_name) ! given a name,check the local and parameter lists local x,y,temp,temp_list,temp_count; x:=index(dbg$local_list,variable_name); y:=index(dbg$param_list,variable_name); if x <> 0 then ! found name in local list ! calculate what number it is list_name:="local"; temp:=x; temp_list:=dbg$local_list else if y <> 0 then temp:=y; list_name:="parameter"; temp_list:=dbg$param_list else return 0 ! not a scoped name endif; endif; temp_count:=0; temp_list:=substr(temp_list,1,temp-1); loop temp:=index(temp_list," "); exitif temp=0; temp_count:=temp_count+1; temp_list:=substr(temp_list,temp+1,999); endloop; ! need to also return name of list return temp_count; ! this will be the nth name in the list endprocedure ! Page 10 pce_init_translate; ! initilize stuff for translation routines pce$vt200_keys; ! define the VT200 keypad set(shift_key, pf1); ! define the 'shift' key set(timer, ON, "Executing"); ! display this when performing long procedures set(debug, program, "dbg$_debug"); ! set up the debug program eve$arg1_spell := 'string'; ! > added 870713 - RHS dictionary$available := 0; ! > added 870713 - RHS dictionary$buffer := 0; ! > added 870713 - RHS default$buffer := 0; ! > added 870713 - RHS define_key ("eve_search('')", key_name(e1,shift_key), "Search"); define_key ("eve_set_rectangular", kp7, "set rectangular" ); define_key ("eve_set_norectangular", key_name(kp7,shift_key),"set norectangular" ); eve_set_tabs_at('7 11 15 19 23 27 31 35 39 43 47 51 55 59 63 67 71 75 79 83 87'); ! FORTRAN tabs define_key ("eve_set_tabs_at('5 9 13 17 21 25 29 33 37 41 45 49 53 57 61 65 69 73 77 81 85')", key_name(pf4,shift_key),"COBOL TABS (SPACES)" ); define_key ("compile(current_buffer)", f7, "Compile current_buffer"); define_key ("debugon('')", key_name(f7,shift_key), "DEBUG ON");