! TPU$DEBUG.TPU 		10-AUG-1990 08:59			Page 1

module tpu$$debug ident "V03-005"

!*************************************************************************
!									 *
!	      © 2002 BY							 *
!	      COMPAQ COMPUTER CORPORATION                                *
!	      © 2002 BY							 *
!	      ELECTRONIC DATA SYSTEMS LIMITED                            *
!									 *
! 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 OR 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  COMPAQ COMPUTER *
! CORPORATION OR EDS.                                                    *
!									 *
! NEITHER  COMPAQ  NOR  EDS  ASSUME ANY RESPONSIBILITY FOR  THE  USE  OR *
! RELIABILITY  OF  THIS SOFTWARE ON EQUIPMENT WHICH IS NOT  SUPPLIED  BY *
! COMPAQ.                                                                *
!									 *
!*************************************************************************
!
!++
! FACILITY:
!	DECTPU - Text Processing Utility
!	EVE - Extensible Versatile Editor
!
! ABSTRACT:
!	This is the source program for the DECTPU debugger.
!
! ENVIRONMENT:
!	VAX/VMS, RISC/ULTRIX
!
!Author: Mark Bramhall
!
! CREATION DATE: 10-Oct-1986
!
! MODIFIED BY:
!
!    V03-005   EDS   16-Jan-2002    Fix TPU_XBUGS 330 & 332
!
!--

! TPU$DEBUG.TPU 							Page 2

!++
!				Table of Contents 
!
!				  TPU$DEBUG.TPU
!				10-AUG-1990 08:59
!
!	Procedure name			Page	Description
!	--------------			----	------------
!
!	tpu$$debug 			   4	Main debugger routine
!	tpu$$debug_find_buffer 		   5	Find a buffer by name
!	tpu$$debug_source 		   6	Get buffer that has the proc
!	tpu$$debug_parse 		   7	Parser
!	tpu$$debug_get_token 		   8	Get a token for the parser
!	tpu$$debug_get_integer 		   9	Get an integer for the parser
!	tpu$$debug_get_command 		  10	Get the command
!	tpu$$debug_prompt 		  11	Prompt for input
!	tpu$$debug_strip_quotes 	  12	Strip surrounding quotes
!	tpu$$debug_set_breakpoint 	  13	SET BREAK w/ forward ref's
!	tpu$$debug_show_breakpoints 	  14	List the breakpoints
!	tpu$$debug_output 		  15	Output through debug status-line
!	tpu$$debug_deposit 		  16	Change locals and globals
!	tpu$$debug_examine 		  17	Get a value (printable)
!	tpu$$debug_dump 		  18	Make a variable printable
!	tpu$$debug_help 		  19	Display the help
!	tpu$$read_line 			  20	READ_LINE with readaborted handled
!	debugon 			  20	Invoke the debugger (old style)
!	eve_debug 			  20	EVE DEBUG command
!--

! TPU$DEBUG.TPU 							Page 3

constant tpu$$k_no_command := 0;
constant tpu$$k_step_command := 1;
constant tpu$$k_go_command := 2;
constant tpu$$k_break_command := 3;
constant tpu$$k_cancel_command := 4;
constant tpu$$k_tpu_command := 5;
constant tpu$$k_examine_command := 6;
constant tpu$$k_deposit_command := 7;
constant tpu$$k_show_break_command := 8;
constant tpu$$k_window_command := 9;
constant tpu$$k_scroll_command := 10;
constant tpu$$k_shift_command := 11;
constant tpu$$k_help_command := 12;
constant tpu$$k_display_command := 13;
constant tpu$$k_spawn_command := 14;
constant tpu$$k_attach_command := 15;
constant tpu$$k_quit_command := 16;
constant tpu$$k_prompt_command := 17;

! TPU$DEBUG.TPU 							Page 4

procedure tpu$$debug 			! Main debugger routine

local   old_row,
	old_length,
	old_window,
	old_buffer,
	old_next_buffer,
	here,
	a_break,
	old_procedure_name,
	the_line,
	the_banner,
	mapped_buffer,
	in_help,
	start_mark,
	the_range,
	the_command,
	arg_1,
	arg_2,
	the_top,
	the_bottom,
	temp;

on_error

    if error <> TPU$_WINDNOTMAPPED
    then
	message (error_text);
    endif;

endon_error;

if get_info (tpu$$use_eve_prompting, 'type') <> INTEGER
then
    tpu$$use_eve_prompting := 0;
endif;

old_procedure_name := tpu$$x_procedure_name;

tpu$$x_procedure_name := get_info (DEBUG, "procedure");
the_line := get_info (DEBUG, "line_number");
if the_line = 0
then
    the_line := debug_line;
endif;

a_break := (tpu$$x_procedure_name <> "EVE_DEBUG") and
	   (tpu$$x_procedure_name <> "DEBUGON");

if (not a_break) and (old_procedure_name = tpu$$x_procedure_name)
then
    set (DEBUG, ON);
    return;
endif;

old_row := get_info (SCREEN, "prompt_row");
old_length := get_info (SCREEN, "prompt_length");
old_window := current_window;
if old_window <> 0
then
    if current_buffer <> get_info (old_window, "buffer")
    then
	old_buffer := current_buffer;
    endif;
endif;

if old_buffer <> 0
then
    here := mark (NONE);
endif;

old_next_buffer := get_info (BUFFERS, "next");

if get_info (tpu$$x_window_row, "type") <> INTEGER
then
    tpu$$x_window_row := 1;
    tpu$$x_window_length := 7;
endif;

set (PROMPT_AREA, tpu$$x_window_row + tpu$$x_window_length - 1, 1, NONE);

if get_info (tpu$x_debug_window, "type") <> WINDOW
then
    tpu$x_debug_window := create_window (tpu$$x_window_row,
					 tpu$$x_window_length - 1,
					 ON);
    temp := tpu$$x_window_length / 3;
    set (SCROLLING, tpu$x_debug_window, ON, temp, temp, 0);
endif;

if get_info (tpu$$x_debug_buffer, "type") <> BUFFER
then
    tpu$$x_debug_buffer := create_buffer ("$DEBUG$BUFFER$");
    set (SYSTEM, tpu$$x_debug_buffer);
    set (NO_WRITE, tpu$$x_debug_buffer);
    set (EOB_TEXT, tpu$$x_debug_buffer, "");
endif;

if a_break
then
    tpu$$x_procedure_start := tpu$$debug_source (tpu$$x_procedure_name);
    if tpu$$x_procedure_start <> 0
    then
	position (tpu$$x_procedure_start);
    else
	position (tpu$$x_debug_buffer);
    endif;

    if (not get_info (tpu$x_debug_window, "visible")) or
	(get_info (tpu$x_debug_window, "buffer") <> current_buffer)
    then
	map (tpu$x_debug_window, current_buffer);
    endif;

    position (tpu$x_debug_window);

    if tpu$$x_procedure_start <> 0
    then
	position (tpu$$x_procedure_start);
	move_vertical (the_line - 1);
	start_mark := mark (NONE);
	move_vertical (1);
	move_horizontal (-1);
	the_range := create_range (start_mark, mark (NONE), BOLD);
    else
	position (tpu$$x_debug_buffer);
    endif;

    if tpu$$x_procedure_name = ""
    then
	the_banner := fao ("Break at line !UL in !AS",
			   the_line,
			   "*** Unknown Program ***");
    else
	the_banner := fao ("Break at line !UL in !AS",
			   the_line,
			   tpu$$x_procedure_name);
    endif;
else
    if not get_info (tpu$x_debug_window, "visible")
    then
	map (tpu$x_debug_window, tpu$$x_debug_buffer);
    else
	if get_info (get_info (tpu$x_debug_window, "buffer"), 'type')
	    <> BUFFER
	then
	    map (tpu$x_debug_window, tpu$$x_debug_buffer);
	    position (tpu$x_debug_window);
	endif;
    endif;
    ! Procedure tpu$$debug_module_ident is dynamically created by TPU
    ! to return the module ident string.

    the_banner := "TPU$DEBUG " + tpu$$debug_module_ident;
endif;
mapped_buffer := get_info (tpu$x_debug_window, "buffer");

tpu$$debug_output (the_banner);

update (ALL);

if old_next_buffer = 0
then
    temp := get_info (BUFFERS, "last");
else
    temp := get_info (BUFFERS, "first");
    loop
	exitif temp = old_next_buffer;
	temp := get_info (BUFFERS, "next");
    endloop;
    temp := get_info (BUFFERS, "previous");
endif;

in_help := 0;
loop
    temp := tpu$$read_line ("Debug: ");
    if temp = 0
    then
	return;
    endif;
    the_command := tpu$$debug_parse (temp, arg_1, arg_2);
    if the_command = 0
    then
	case last_key
	    [E5, key_name (UP, SHIFT_KEY)]:
		the_command := tpu$$k_scroll_command;
		arg_1 := 3 - tpu$$x_window_length;
	    [E6, key_name (DOWN, SHIFT_KEY)]:
		the_command := tpu$$k_scroll_command;
		arg_1 := tpu$$x_window_length - 3;
	    [key_name (RIGHT, SHIFT_KEY)]:
		the_command := tpu$$k_shift_command;
		arg_1 := 40;
	    [key_name (LEFT, SHIFT_KEY)]:
		the_command := tpu$$k_shift_command;
		arg_1 := -40;
	    [CTRL_D_KEY]:
		if get_info (SYSTEM, "operating_system") = ULTRIX
		then
		    the_command := tpu$$k_display_command;
		endif;
	    [F10, CTRL_Z_KEY]:
		the_command := tpu$$k_display_command;
	    [HELP, PF2]:
		the_command := tpu$$k_help_command;
	endcase;
    endif;
    case the_command
	[tpu$$k_no_command, tpu$$k_step_command]:		! Step
	    if (not a_break) and (the_command = tpu$$k_no_command)
	    then
		tpu$$debug_output ("STEP command is not assumed at this point");
	    else
		set (DEBUG, ON);
		if old_length <> 0
		then
		    set (PROMPT_AREA, old_row, old_length, NONE);
		endif;
		if old_window <> 0
		then
		    position (old_window);
		endif;
		if old_buffer <> 0
		then
		    position (old_buffer);
		endif;
		if here <> 0
		then
		    position (here);
		endif;
		return;
	    endif;

	[tpu$$k_go_command]:		! Go
	    if old_length <> 0
	    then
		set (PROMPT_AREA, old_row, old_length, NONE);
	    endif;
	    unmap (tpu$x_debug_window);
	    if old_window <> 0
	    then
		position (old_window);
	    endif;
	    if old_buffer <> 0
	    then
		position (old_buffer);
	    endif;
	    if here <> 0
	    then
		position (here);
	    endif;
	    update (ALL);
	    tpu$$x_procedure_name := 0;
	    return;
	[tpu$$k_break_command]:		! Set Breakpoint
	    tpu$$debug_set_breakpoint (arg_1);
	[tpu$$k_cancel_command]:		! Cancel Breakpoint
	    if arg_1 = "*"
	    then
		set (DEBUG, OFF, ALL);
		tpu$$debug_output ("All breakpoints canceled");
	    else
		set (DEBUG, OFF, arg_1);
		tpu$$debug_output (fao ("Breakpoint !AS canceled", arg_1));
	    endif;
	[tpu$$k_tpu_command]:		! TPU
	    if old_length <> 0
	    then
		set (PROMPT_AREA, old_row, old_length, NONE);
	    endif;
	    if old_window <> 0
	    then
		position (old_window);
	    endif;
	    if old_buffer <> 0
	    then
		position (old_buffer);
	    endif;
	    if here <> 0
	    then
		position (here);
	    endif;
	    execute (arg_1);
	    position (mapped_buffer);
	    set (PROMPT_AREA, tpu$$x_window_row + tpu$$x_window_length - 1, 1,
		 NONE);
	[tpu$$k_examine_command]:		! Examine
	    in_help := in_help or tpu$$debug_examine (arg_1);
	[tpu$$k_deposit_command]:		! Deposit
	    tpu$$debug_deposit (arg_1, arg_2);
	[tpu$$k_show_break_command]:		! Show Breakpoints
	    in_help := in_help or tpu$$debug_show_breakpoints;
	[tpu$$k_window_command]:		! Set Window
	    tpu$$x_window_row := arg_1;
	    tpu$$x_window_length := arg_2;
            if (tpu$$x_window_row +
                   tpu$$x_window_length) > get_info(SCREEN, "length")
            then
                tpu$$x_window_length :=
                   get_info(SCREEN, "length") - tpu$$x_window_row;
            endif;
	    set (PROMPT_AREA, tpu$$x_window_row + tpu$$x_window_length - 1, 1,
		 NONE);
	    the_top := tpu$$x_window_row;
	    the_bottom := the_top + tpu$$x_window_length - 2;
	    the_top := the_top - get_info (tpu$x_debug_window, "visible_top");
	    the_bottom := the_bottom - (1 + get_info (tpu$x_debug_window,
						      "visible_bottom"));
	    adjust_window (tpu$x_debug_window, the_top, the_bottom);
	    temp := tpu$$x_window_length / 3;
	    set (SCROLLING, tpu$x_debug_window, ON, temp, temp, 0);
	    update (ALL);
	[tpu$$k_scroll_command]:		! Scroll
	    if arg_1 = NONE
	    then
		arg_1 := 2 - tpu$$x_window_length;
	    endif;
	    scroll (tpu$x_debug_window, arg_1);
	[tpu$$k_shift_command]:		! Shift
	    if arg_1 = NONE
	    then
		arg_1 := 40;
	    endif;
	    shift (tpu$x_debug_window, arg_1);
	    update (tpu$x_debug_window);
	[tpu$$k_help_command]:		! HELP
	    tpu$$debug_help;
	    in_help := 1;
	[tpu$$k_display_command]:	! DISPLAY SOURCE
	    if in_help
	    then
		if mapped_buffer <> tpu$$x_debug_buffer
		then
		    map (tpu$x_debug_window, mapped_buffer);
		endif;
		erase (tpu$$x_debug_buffer);
		tpu$$debug_output (the_banner);
		in_help := 0;
	    endif;
	[tpu$$k_spawn_command]:		! SPAWN
	    if arg_1 = NONE
	    then
		arg_1 := "";
	    endif;
	    spawn (arg_1);
	[tpu$$k_attach_command]:	! ATTACH
	    if arg_1 = NONE
	    then
		attach;
	    else
		attach (arg_1);
	    endif;
            set(status_line, tpu$x_debug_window, REVERSE,
                   str(get_info(tpu$x_debug_window, "status_line")));
            update (tpu$x_debug_window);
	[tpu$$k_quit_command]:		! QUIT
	    if old_length <> 0
	    then
		set (PROMPT_AREA, old_row, old_length, NONE);
	    endif;
	    unmap (tpu$x_debug_window);
	    if old_window <> 0
	    then
		position (old_window);
	    endif;
	    if old_buffer <> 0
	    then
		position (old_buffer);
	    endif;
	    if here <> 0
	    then
		position (here);
	    endif;
	    update (ALL);
	    tpu$$x_procedure_name := 0;
	    abort;

	[tpu$$k_prompt_command]:		! Set prompt
%ifdef eve$prompt_line
%then
	    if arg_1 = "EVE"
	    then
		tpu$$use_eve_prompting := 1;
	    else
		tpu$$use_eve_prompting := 0;
	    endif;
	    refresh;	! get rid of previous prompt area
%else
	    message ("EVE prompting not available");
%endif
	    ;
	[INRANGE, OUTRANGE]:
	    message (fao ("Unrecognized command: !AS", temp));
    endcase;
endloop;

endprocedure;

! TPU$DEBUG.TPU 							Page 5

procedure tpu$$debug_find_buffer (buffer_name)	! Find a buffer by name

local   the_buffer,			! Used to hold the buffer pointer
	the_name;			! A read/write copy of the name

the_name := buffer_name;
if get_info (system, "operating_system") = VMS
then
    change_case (the_name, UPPER);
endif;
the_buffer := get_info (BUFFERS, "first");
loop
    exitif (the_buffer = 0);
    exitif (the_name = get_info (the_buffer, "name"));
    the_buffer := get_info (BUFFER, "next");
endloop;
return the_buffer;

endprocedure

! TPU$DEBUG.TPU 							Page 6

procedure tpu$$debug_source (the_procedure)	! Get buffer that has the proc

local   the_pattern,
	the_buffer,
	buffer_name,
	this_buffer,
	the_range,
	here,
	ok_to_search,
	the_file,
	file_name,
	full_spec;

on_error

    if error <> TPU$_STRNOTFOUND
    then
	message (error_text);
    endif;

endon_error;

if the_procedure = ""
then
    return 0;
endif;

here := mark (NONE);

if get_info (tpu$$x_source_buffer, "type") <> BUFFER
then
    tpu$$x_source_buffer := create_buffer ("$DEBUG$SOURCE$");
    set (SYSTEM, tpu$$x_source_buffer);
    set (NO_WRITE, tpu$$x_source_buffer);
endif;

if get_info (tpu$$x_debug_directory, "type") <> BUFFER
then
    tpu$$x_debug_directory := create_buffer ("$DEBUG$DIRECTORY$");
    set (SYSTEM, tpu$$x_debug_directory);
    set (NO_WRITE, tpu$$x_debug_directory);
endif;

! search the list of found procedures to see which buffer it's in,
! default to source buffer if not found

position (beginning_of (tpu$$x_debug_directory));
the_range := search (LINE_BEGIN + the_procedure + ascii (9), FORWARD);
if the_range <> 0
then
    position (end_of (the_range));
    buffer_name := substr (current_line, current_offset + 2,
			   length (current_line));
    the_buffer := tpu$$debug_find_buffer (buffer_name);
    if the_buffer <> 0
    then
	position (the_buffer);
    else
	position (tpu$$x_source_buffer);
    endif;
else
    position (tpu$$x_source_buffer);
endif;

the_pattern := LINE_BEGIN +
	       "procedure" + span ("	 ") + the_procedure +
	       (LINE_END | notany ("abcdefghijklmnopqrstuvwxyz" +
				   "ABCDEFGHIJKLMNOPQRSTUVWXYZ" +
				   "1234567890$_" +
				   "àáâãäåæçèéêëìíîïñòóôõö÷øùúûüý" +
				   "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÑÒÓÔÕÖ×ØÙÚÛÜÝß"));
ok_to_search := TRUE;

loop

    ! Is it in this buffer?

    if ok_to_search
    then
	if current_buffer = tpu$$x_source_buffer
	then
	    message (fao ("Searching debugger source buffer " +
			  "for procedure !AS...", the_procedure));
	else
	    message (fao ("Searching buffer !AS for procedure !AS...",
			  get_info (current_buffer, "name"), the_procedure));
	endif;
	the_range := search (the_pattern, REVERSE);

	if the_range = 0
	then
	    the_range := search (the_pattern, FORWARD);
	endif;
	message ("");
    endif;
    ok_to_search := TRUE;

    if the_range <> 0
    then
	if the_buffer <> current_buffer
	then
	    buffer_name := get_info (current_buffer, "name");
	    position (end_of (tpu$$x_debug_directory));
	    copy_text (the_procedure + ascii (9) + buffer_name);
	endif;
	position (here);
	return beginning_of (the_range);
    endif;

    ! Not in this buffer -- ask for a file

    tpu$$debug_output (fao ("Procedure !AS not in source buffer",
			    the_procedure));
    the_file := tpu$$read_line (fao ("File name (containing procedure !AS): ",
				     the_procedure));
    if the_file = 0
    then
	position (here);
	return 0;
    endif;
    if get_info (system, "operating_system") = ULTRIX
    then
	edit (the_file, TRIM, COMPRESS);
    else
	if get_info (system, "operating_system") = VMS
	then
	    edit (the_file, UPPER, TRIM, COMPRESS);
	endif;
    endif;
    if the_file = ""
    then
	message ("");	! clear out possible error messages
	position (here);
	return 0;
    endif;

    if get_info (tpu$$debug_last_file, "type") <> STRING
    then
	tpu$$debug_last_file := "";
    endif;
    full_spec := file_search (the_file, ".TPU", tpu$$debug_last_file);

    if full_spec <> ""
    then
	this_buffer := get_info (BUFFER, "first");
	loop
	    exitif this_buffer = 0;
	    exitif full_spec = get_info (this_buffer, "file_name");
	    exitif full_spec = get_info (this_buffer, "output_file");
	    this_buffer := get_info (BUFFER, "next");
	endloop;
	if this_buffer = 0
	then
	    message ("Reading into debugger source buffer: " + full_spec);
	    position (end_of (tpu$$x_source_buffer));
	    read_file (full_spec);
	else
	    message ("Using buffer: " + get_info (this_buffer, "name"));
	    position (this_buffer);
	endif;
	! save filespec for defaulting fields of subsequent file names
	tpu$$debug_last_file := full_spec;
    else
	full_spec := file_parse (the_file, ".TPU", tpu$$debug_last_file);
	file_name := file_parse (the_file, ".TPU", tpu$$debug_last_file,
				 NAME, TYPE);
	this_buffer := get_info (BUFFER, "first");
	loop
	    exitif this_buffer = 0;
	    exitif get_info (this_buffer, "name") = the_file;
	    exitif get_info (this_buffer, "name") = file_name;
	    exitif get_info (this_buffer, "name") = full_spec;
	    this_buffer := get_info (BUFFER, "next");
	endloop;

	if this_buffer <> 0
	then
	    tpu$$debug_last_file := file_name;
	    message ("Using buffer: " + get_info (this_buffer, "name"));
	    position (this_buffer);
	else
	    message (fao ("No files matching: !AS", the_file), 0);
	    ok_to_search := FALSE;
	endif;
    endif;
endloop;

endprocedure

! TPU$DEBUG.TPU 							Page 7

procedure tpu$$debug_parse (input_line, arg_1, arg_2)		! Parser

local   input,
	command,
	temp_arg,
	arg_2_length,
	the_offset;

on_error
    if error = TPU$_MISSINGQUOTE
    then
	message ("Character string is missing a terminating quote");
    endif;
    return - 2;
endon_error;

input := input_line;
edit (input, COMPRESS, TRIM, UPPER);
if input = ""
then
    return 0;
endif;

command := tpu$$debug_get_command (input, 8,
				   " ATTACH " + " CANCEL " + " D      " +
				   " DEPOSIT" + " DISPLAY" + " EXAMINE" +
				   " GO     " + " HELP   " + " S      " +
				   " SCROLL " + " SET    " + " SH     " +
				   " SHIFT  " + " SHOW   " + " SPAWN  " +
				   " STEP   " + " TPU    " + " QUIT   ");

case command from 1 to 18

    [1]:	! ATTACH command
	if not tpu$$debug_get_token (input, arg_1)
	then
	    arg_1 := NONE;
	else
	    temp_arg := arg_1;
	    if not tpu$$debug_get_integer (arg_1, arg_1)
	    then
		arg_1 := temp_arg;
		tpu$$debug_strip_quotes (arg_1);
	    endif;
	endif;
	if input = ""
	then
	    return tpu$$k_attach_command;
	endif;

    [2]:	! CANCEL command
	temp_arg := input;
	if tpu$$debug_get_command (input, 11, " BREAKPOINT") <> 1
	then
	    input := temp_arg;
	endif;
	if tpu$$debug_prompt (input, "Procedure name")
	then
	    tpu$$debug_get_token (input, arg_1);
	    if tpu$$debug_get_integer (input, arg_2)
	    then
		if input = ""
		then
		    return tpu$$k_cancel_command;
		endif;
	    endif;
	endif;

    [3, 12]:  	! D and SH
	message ("Ambiguous command");

    [4]:  	! DEPOSIT command
	the_offset := index (input, ":=");
	if the_offset <> 0
	then
	    arg_1 := substr (input, 1, the_offset - 1);
	    edit (arg_1, TRIM, OFF);
	    if arg_1 = ""
	    then
		message ("Identifier required");
	    else
		if index (arg_1, " ") <> 0
		then
		    message ("Illegal identifier");
		else
		    arg_2_length := length (input) - the_offset - 1;
		    arg_2 := substr (input, the_offset + 2, arg_2_length);
		    edit (arg_2, TRIM, OFF);
		    if arg_2 = ""
		    then
			message ("Expression required");
		    else
			return tpu$$k_deposit_command;
		    endif;
		endif;
	    endif;
	endif;

    [5]:	! DISPLAY command
	tpu$$debug_get_command (input, 7, " SOURCE");
	if input = ""
	then
	    return tpu$$k_display_command;
	endif;

    [6]:  	! EXAMINE command
	if tpu$$debug_prompt (input, "Identifier name")
	then
	    tpu$$debug_get_token (input, arg_1);
	    if input = ""
	    then
		return tpu$$k_examine_command;
	    endif;
	endif;

    [7]:  	! GO command
	if input = ""
	then
	    return tpu$$k_go_command;
	endif;

    [8]:  	! HELP command
	if input = ""
	then
	    return tpu$$k_help_command;
	endif;

    [9, 16]:  	! STEP command
	if tpu$$debug_get_integer (input, arg_1)
	then
	    if input = ""
	    then
		return tpu$$k_step_command;
	    endif;
	endif;

    [10]:  	! SCROLL command
	if tpu$$debug_get_integer (input, arg_1)
	then
	    if input = ""
	    then
		return tpu$$k_scroll_command;
	    endif;
	endif;

    [11]:  	! SET command
	if tpu$$debug_prompt (input, "Set command")
	then
	    command := tpu$$debug_get_command (input, 11,
					       " BREAKPOINT" +
					       " PROMPT    " +
					       " WINDOW    ");
	    case command from 1 to 3

		[1]: 	! BREAKPOINT
		    if tpu$$debug_prompt (input, "Procedure name")
		    then
			tpu$$debug_get_token (input, arg_1);
			if tpu$$debug_get_integer (input, arg_2)
			then
			    if input = ""
			    then
				return tpu$$k_break_command;
			    endif;
			endif;
		    endif;

		[2]: 	! PROMPT
		    if tpu$$debug_prompt (input, "Source")
		    then
			tpu$$debug_get_token (input, arg_1);
			if input = ""
			then
			    return tpu$$k_prompt_command;
			endif;
		    endif;

		[3]: 	! WINDOW
		    if tpu$$debug_get_integer (input, arg_1)
		    then
			if tpu$$debug_get_integer (input, arg_2)
			then
			    if (input = "") and (arg_2 <> NONE)
			    then
				return tpu$$k_window_command;
			    endif;
			endif;
		    endif;
	    endcase;
	endif;

    [13]:  	! SHIFT command
	if tpu$$debug_get_integer (input, arg_1)
	then
	    if input = ""
	    then
		return tpu$$k_shift_command;
	    endif;
	endif;

    [14]:  	! SHOW command
	tpu$$debug_get_command (input, 12, " BREAKPOINTS");
	if input = ""
	then
	    return tpu$$k_show_break_command;
	endif;

    [15]:	! SPAWN command
	if input = ""
	then
	    arg_1 := NONE;
	else
	    arg_1 := input;
	    tpu$$debug_strip_quotes (arg_1);
	endif;
	return tpu$$k_spawn_command;

    [17]:  	! TPU command
	if tpu$$debug_prompt (input, "TPU command")
	then
	    arg_1 := input;
	    return tpu$$k_tpu_command;
	endif;

    [18]:  	! QUIT command
	if input = ""
	then
	    return tpu$$k_quit_command;
	endif;

endcase;

return - 1;
endprocedure;

! TPU$DEBUG.TPU 							Page 8

procedure tpu$$debug_get_token (input, token)	! Get a token for the parser

local   the_offset,
	input_length;

if input = ""
then
    return 0;
endif;

input_length := length (input);
the_offset := index (input, " ");
if the_offset = 0
then
    the_offset := input_length + 1;
endif;

token := substr (input, 1, the_offset - 1);
input := substr (input, the_offset + 1, input_length - the_offset);

return 1;
endprocedure;

! TPU$DEBUG.TPU 							Page 9

procedure tpu$$debug_get_integer (input, value)	 ! Get an integer for the parser

local   token;

on_error
    return 0;
endon_error;

if tpu$$debug_get_token (input, token) = 0
then
    value := NONE;
else
    value := int (token);
endif;

return 1;
endprocedure;

! TPU$DEBUG.TPU 							Page 10

procedure tpu$$debug_get_command (input, char_size, choices)   ! Get the command

local   token,
	command;

if tpu$$debug_get_token (input, token) = 0
then
    return 0;
endif;

command := index (choices, " " + token);
if command <> 0
then
    command := command / char_size + 1;
endif;

return command;

endprocedure

! TPU$DEBUG.TPU 							Page 11

procedure tpu$$debug_prompt (input, the_prompt)		! Prompt for input

on_error
    return 0;
endon_error;

if input = ""
then
    input := tpu$$read_line (the_prompt + ": ");
    edit (input, COMPRESS, TRIM, UPPER, OFF);
    if input = ""
    then
	message (the_prompt + " required");
	return 0;
    endif;
endif;

return 1;
endprocedure;

! TPU$DEBUG.TPU 							Page 12

procedure tpu$$debug_strip_quotes (input)	! Strip surrounding quotes

constant single_quote := "'";
constant double_quote := '"';

local
	first_char,
	last_char;

first_char := substr (input, 1, 1);
last_char := substr (input, length (input), 1);

if ((first_char = single_quote) and (last_char = single_quote)) or
    ((first_char = double_quote) and (last_char = double_quote))
then
    input := substr (input, 2, length (input) - 2);
endif;

endprocedure;

! TPU$DEBUG.TPU 							Page 13

procedure tpu$$debug_set_breakpoint (the_arg)	! SET BREAK w/ forward ref's

local   breakpoint_fao,
	breakpoint_failed;

on_error
    [TPU$_NONAMES]:
	breakpoint_failed := TRUE;
    [OTHERWISE]:
	;
endon_error;

breakpoint_fao := "Breakpoint set at !AS";
breakpoint_failed := FALSE;
set (DEBUG, ON, the_arg);
if breakpoint_failed
then
    compile (the_arg);
    breakpoint_fao := "Breakpoint set on undefined procedure !AS";
    breakpoint_failed := FALSE;
    set (DEBUG, ON, the_arg);
    if breakpoint_failed
    then
	breakpoint_fao := "Failed to set breakpoint on !AS";
    endif;
endif;
tpu$$debug_output (fao (breakpoint_fao, the_arg));

endprocedure;

! TPU$DEBUG.TPU 							Page 14

procedure tpu$$debug_show_breakpoints		! List the breakpoints

local   temp,
	here,
	count;

on_error
    [TPU$_NONAMES]:
	;
    [OTHERWISE]:
	;
endon_error;

here := mark (NONE);
position (tpu$$x_debug_buffer);
erase (tpu$$x_debug_buffer);

count := 0;
temp := get_info (DEBUG, "breakpoint");
loop
    exitif temp = 0;
    split_line;
    move_vertical (-1);
    copy_text (fao ("Breakpoint set at !AS", temp));
    move_horizontal (1);
    count := count + 1;
    temp := get_info (DEBUG, "next");
endloop;

if count = 0
then
    tpu$$debug_output ("There are no breakpoints");
    position (here);
    return 0;
else
    position (beginning_of (current_buffer));
    map (tpu$x_debug_window, current_buffer);
    tpu$$debug_output ("Press CTRL/Z or EXIT to remove breakpoint list");
    update (tpu$x_debug_window);
    return 1;
endif;

endprocedure;

! TPU$DEBUG.TPU 							Page 15

procedure tpu$$debug_output (a_string)	! Output through debug status-line

if not get_info (tpu$x_debug_window, "visible")
then
    map (tpu$x_debug_window, tpu$$x_debug_buffer);
endif;
set (STATUS_LINE, tpu$x_debug_window, REVERSE, a_string);
update (tpu$x_debug_window);

endprocedure;

! TPU$DEBUG.TPU 							Page 16

procedure tpu$$debug_deposit (the_identifier,	! Change locals and globals
			      the_value)

on_error

    tpu$$debug_output (error_text);

endon_error;

execute (fao ("on_error tpu$$debug_output (error_text); endon_error " +
	      "set (DEBUG, '!AS', !AS)",
	      the_identifier, the_value));

endprocedure;

! TPU$DEBUG.TPU 							Page 17

procedure tpu$$debug_examine (the_identifier)	! Get a value (printable)

local   the_value,
	local_variable,
	low_index,
	high_index,
	the_index;

on_error
    [TPU$_NONAMES]:
	! Let user examine an array element
	the_index := index (the_identifier, "{");
	if the_index <> 0
	then
	    local_variable := substr (the_identifier, 1, the_index - 1);
	    ! an array variable?
	    local_variable := execute ("on_error" +
				       "[TPU$_UNDEFINEDPROC]:" +
				       "  tpu$$debug_output " +
				       "   ('No such variable');" +
				       "  return 0;" +
				       " [OTHERWISE]:" +
				       "  return 0;" +
				       "endon_error;" +
				       "return (" + local_variable + ");");
	    if get_info (local_variable, "type") = ARRAY
	    then
		! get contents of array element
		local_variable := execute ("on_error" +
					   "[TPU$_UNDEFINEDPROC]:" +
					   "  tpu$$debug_output " +
					   "   ('No such variable');" +
					   "  return 0;" +
					   " [OTHERWISE]:" +
					   "  return 0;" +
					   "endon_error;" +
					   "return (" + the_identifier + ");");
		tpu$$debug_output (fao ("!AS: !AS",
					the_identifier,
					tpu$$debug_dump (local_variable)));
		return;
	    endif;
	endif;
	tpu$$debug_output ("No such variable");
	return;
endon_error;

tpu$$debug_examine := 0;
the_value := get_info (DEBUG, "examine", the_identifier);
if get_info (the_value, "type") = ARRAY
then
    tpu$$debug_examine := 1;
    position (tpu$$x_debug_buffer);
    erase (tpu$$x_debug_buffer);
    low_index := get_info (the_value, "low_index");
    high_index := get_info (the_value, "high_index");
    if low_index <= high_index
    then
	copy_text (fao ("Array: !AS, fast indexing from !SL to !SL",
			the_identifier, low_index, high_index));
    else
	copy_text (fao ("Array: !AS, no fast indexing", the_identifier));
    endif;
    the_index := get_info (the_value, "first");
    if the_index = tpu$k_unspecified
    then
	split_line;
	copy_text (" <empty>");
    else
	loop
	    split_line;
	    copy_text (fao (" {!AS}: !AS",
			    tpu$$debug_dump (the_index),
			    tpu$$debug_dump (the_value {the_index})));
	    the_index := get_info (the_value, "next");
	    exitif the_index = tpu$k_unspecified;
	endloop;
    endif;
    position (beginning_of (current_buffer));
    map (tpu$x_debug_window, current_buffer);
    update (tpu$x_debug_window);
    if get_info (SYSTEM, "operating_system") = ULTRIX
    then
	if not get_info (SCREEN, "vt100")
	then
	    tpu$$debug_output ("Use PREV SCREEN and NEXT SCREEN to SCROLL," +
			       " CTRL/D or EXIT to display source");
	else
	    tpu$$debug_output ("Use GOLD/UP, and GOLD/DOWN to SCROLL, " +
			       "CTRL/D to display source");
	endif;
    else
	if not get_info (SCREEN, "vt100")
	then
	    tpu$$debug_output ("Use PREV SCREEN and NEXT SCREEN to SCROLL," +
			       " CTRL/Z or EXIT to display source");
	else
	    tpu$$debug_output ("Use GOLD/UP, and GOLD/DOWN to SCROLL, " +
			       "CTRL/Z to display source");
	endif;
    endif;
else
    tpu$$debug_output (fao ("!AS: !AS",
			    the_identifier,
			    tpu$$debug_dump (the_value)));
endif;

endprocedure;

! TPU$DEBUG.TPU 							Page 18

procedure tpu$$debug_dump (the_variable)	! Make a variable printable

local   the_name,
	the_low,
	the_high,
	the_first,
	the_last;

case get_info (the_variable, "type")
    [BUFFER]:
	return (fao ("Buffer: !AS", get_info (the_variable, "name")));
    [INTEGER]:
	return (fao ("Integer: !SL", the_variable));
    [KEYWORD]:
	return (fao ("Keyword: !AS", get_info (the_variable, "name")));
    [MARKER]:
	return (fao ("Marker in buffer: !AS",
		     get_info (get_info (the_variable, "buffer"), "name")));
    [PROCESS]:
	return (fao ("Process: PID = !UL",
		     get_info (the_variable, "pid")));
    [RANGE]:
	return (fao ("Range (buffer = !AS): ""!AS""",
		     get_info (get_info (the_variable, "buffer"), "name"),
		     substr (the_variable, 1, 40)));
    [STRING]:
	return (fao ("String: ""!AS""", the_variable));
    [WINDOW]:
	if get_info (the_variable, "visible")
	then
	    return (fao ("Window: !UL through !UL",
			 get_info (the_variable, "visible_top"),
			 get_info (the_variable, "visible_bottom")));
	else
	    return (fao ("Window (invisible): !UL through !UL",
			 get_info (the_variable, "original_top"),
			 get_info (the_variable, "original_bottom")));
	endif;
    [ARRAY]:
	the_low := get_info (the_variable, "low_index");
	the_high := get_info (the_variable, "high_index");
	the_first := get_info (the_variable, "first");
	the_last := get_info (the_variable, "last");
	if the_first = tpu$k_unspecified
	then
	    if the_low <= the_high
	    then
		return (fao ("Array: <empty>, fast !SL to !SL",
			     the_low, the_high));
	    endif;
	    return ("Array: <empty>");
	endif;
	if the_low <= the_high
	then
	    if get_info (the_first, "type") = INTEGER
	    then
		if get_info (the_last, "type") = INTEGER
		then
		    if the_low <= the_first
		    then
			if the_high >= the_last
			then
			    return (fao ("Array: !SL to !SL, fast !SL to !SL",
					 the_first, the_last,
					 the_low, the_high));
			endif;
		    endif;
		endif;
	    endif;
	endif;
	the_first := tpu$$debug_dump (the_first);
	the_last := tpu$$debug_dump (the_last);
	the_first := substr (the_first, 1, 30);
	the_last := substr (the_last, 1, 30);
	return (fao ("Array: (!AS) to (!AS)", the_first, the_last));
    [WIDGET]:
	the_name := get_info (the_variable, "name");
	return (fao ("!AS Widget: !AS", get_info (the_variable, "class"),
		     the_name));
    [OTHERWISE]:
	the_name := get_info (get_info (the_variable, "type"), "name");
	edit (the_name, LOWER);
	the_name := ascii (ascii (the_name) - 32)
		    + substr (the_name, 2, length (the_name))
		    + ": ";
	return the_name;
endcase;

endprocedure;

! TPU$DEBUG.TPU 							Page 19

procedure tpu$$debug_help		! Display the help

local   temp;

position (tpu$$x_debug_buffer);
erase (tpu$$x_debug_buffer);

copy_text ("TPU$DEBUG has the following commands:");
split_line;
split_line;
copy_text ("    CANCEL BREAKPOINT procedure       ");
copy_text ("    SET BREAKPOINT procedure");
split_line;
copy_text ("    DEPOSIT variable := expression    ");
copy_text ("    SET WINDOW top length");
split_line;
copy_text ("    EXAMINE variable                  ");
copy_text ("    SHIFT distance");
split_line;
copy_text ("    DISPLAY SOURCE                    ");
copy_text ("    SHOW BREAKPOINTS");
split_line;
copy_text ("    GO                                ");
copy_text ("    STEP");
split_line;
copy_text ("    HELP                              ");
copy_text ("    TPU statement");
split_line;
copy_text ("    ATTACH                            ");
copy_text ("    SPAWN");
split_line;
copy_text ("    SCROLL distance                   ");
split_line;

split_line;
copy_text ("TPU$DEBUG has the following key bindings:");
split_line;
split_line;

temp := tpu$$x_window_length - 3;
copy_text (fao ("    Prev Screen   = SCROLL !3<!SL!>        ", -temp));
copy_text (fao ("    Next Screen   = SCROLL !SL", temp));
split_line;
copy_text (fao ("    Gold/Up       = SCROLL !3<!SL!>        ", -temp));
copy_text (fao ("    Gold/Down     = SCROLL !SL", temp));
split_line;
copy_text ("    Gold/Left     = SHIFT -40         ");
copy_text ("    Gold/Right    = SHIFT 40");
split_line;
copy_text ("    Exit          = DISPLAY SOURCE    ");
copy_text ("    CTRL/Z        = DISPLAY SOURCE");
split_line;
copy_text ("    HELP          = HELP              ");
copy_text ("    PF2           = HELP");

position (beginning_of (current_buffer));
map (tpu$x_debug_window, current_buffer);
update (tpu$x_debug_window);
if get_info (SYSTEM, "operating_system") = ULTRIX
then
    if not get_info (SCREEN, "vt100")
    then
	tpu$$debug_output ("Use PREV SCREEN and NEXT SCREEN to SCROLL," +
			   " CTRL/D or EXIT to leave HELP");
    else
	tpu$$debug_output ("Use GOLD/UP, and GOLD/DOWN to SCROLL, " +
			   "CTRL/D to leave HELP");
    endif;
else
    if not get_info (SCREEN, "vt100")
    then
	tpu$$debug_output ("Use PREV SCREEN and NEXT SCREEN to SCROLL," +
			   " CTRL/Z or EXIT to leave HELP");
    else
	tpu$$debug_output ("Use GOLD/UP, and GOLD/DOWN to SCROLL, " +
			   "CTRL/Z to leave HELP");
    endif;
endif;

endprocedure;

! TPU$DEBUG.TPU 							Page 20

procedure tpu$$read_line (the_prompt)	! READ_LINE with readaborted handled
local   our_line;
on_error
    [TPU$_CONTROLC]:
	tpu$$read_line (the_prompt);	! reprompt
    [TPU$_READABORTED]:
endon_error;


if tpu$$use_eve_prompting
then
%ifdef eve$prompt_line
%then

    position (TEXT);
    return eve$prompt_line (the_prompt, eve$$x_prompt_terminators);
%else
    message ("EVE prompting not available");
%endif
    ;
else
    loop
	our_line := read_line (the_prompt);
	exitif last_key <> 0;
    endloop;
endif;
return our_line;
endprocedure;

procedure debugon			! Invoke the debugger (old style)

set (DEBUG, PROGRAM, "tpu$$debug");
break;

endprocedure;

procedure eve_debug			! EVE DEBUG command

set (DEBUG, PROGRAM, "tpu$$debug");
break;

endprocedure

endmodule;

debugon;