org.eclipse.debug.examples.core/pdavm/pda.pl - gerrit/platform/eclipse.platform.debug - Git at Google

 #!perl.exe

 use strict;
 use warnings;
 use IO::Socket;

 #####################################################################
 # Copyright (c) 2005 IBM Corporation and others.
 # All rights reserved. This program and the accompanying materials
 # are made available under the terms of the Eclipse Public License v1.0
 # which accompanies this distribution, and is available at
 # http://www.eclipse.org/legal/epl-v10.html
 #
 # Contributors:
 #     Bjorn Freeman-Benson - initial API and implementation
 #####################################################################

 #####################################################################
 #																	#
 #	I N I T I A L I Z A T I O N   A N D   V A R I A B L E S			#
 #																	#
 #####################################################################
 #
 # The push down automata stack (the data stack)
 #
 my @stack;
 #
 # Load all the code into memory
 # The code is stored as an array of strings, each line of
 # the source file being one entry in the array.
 #
 my $filename = shift;
 open INFILE, $filename or die $!;
 my @code = <INFILE>;
 close INFILE;

 my %labels;
 sub map_labels {
 	#
 	# A mapping of labels to indicies in the code array
 	#
 	%labels = ( );
 	my $idx = 0;
 	while( $idx <= $#code ) {
 		if( length $code[$idx] > 0 ) {
 			$code[$idx] =~ /^\s*(.+?)\s*$/;
 			$code[$idx] = $1;
 			$labels{$1} = $idx if( $code[$idx] =~ /^:(\S+)/ );
 		} else {
 			$code[$idx] = "\n";
 		}
 		$idx ++;
 	}
 }
 map_labels();
 #
 # The stack of stack frames (the control stack)
 # Each stack frame is a mapping of variable names to values.
 # There are a number of special variable names:
 #  _pc_  is the current program counter in the frame
 #        the pc points to the next instruction to be executed
 #  _func_ is the name of the function in this frame
 #
 my @frames;
 my $currentframe;
 $currentframe = {
 	_pc_ => 0,
 	_func_ => 'main'
 	};

 #
 # The command line argument to start a debug session.
 #
 my $debugflag = shift;
 #
 # The port to listen for debug commands on
 # and the port to send debug events to
 #
 my $debugport;
 my $debugport2;
 #
 # The socket to listen for debug commands on
 # and the socket to send debug events on
 #
 my $debugsock;
 my $debugsock2;
 #
 # An input buffer
 #
 my $debugbuf;
 #
 # Breakpoint array
 # breakpoints are stored as a boolean for each line of code
 # if the boolean is true, there is a breakpoint on that line
 #
 my @breakpoints;
 #
 # Mapping of debugger commands to functions that evaluate them
 #
 my %debug_commands = (
 	clear => \&debug_clear_breakpoint,
 	data => \&debug_data,
 	drop => \&debug_drop_frame,
 	eval => \&debug_eval,
 	eventstop => \&debug_event_stop,
 	exit => \&debug_exit,
 	popdata => \&debug_pop,
 	pushdata => \&debug_push,
 	resume => \&debug_resume,
 	set => \&debug_set_breakpoint,
 	setdata => \&debug_set_data,
 	setvar => \&debug_set_variable,
 	stack => \&debug_stack,
 	step => \&debug_step,
 	stepreturn => \&debug_step_return,
 	suspend => \&debug_suspend,
 	var => \&debug_var,
 	watch => \&debug_watch
 );

 #
 # The run flag is true if the VM is running.
 # If the run flag is false, the VM exits the
 # next time the main instruction loop runs.
 #
 my $run = 1;
 #
 # The suspend flag is true if the VM should suspend
 # running the program and just listen for debug commands.
 #
 my $suspend = 0;
 my $started = 1;
 $suspend = "client" if( $debugflag );
 #
 # The step flag is used to control single-stepping.
 # See the implementation of the "step" debug command.
 # The stepreturn flag is used to control step-return.
 # The eventstops table holds which events cause suspends and which do not.
 # The watchpoints table holds watchpoint information.
 #   variablename_stackframedepth => N
 #   N = 0 is no watch
 #   N = 1 is read watch
 #   N = 2 is write watch
 #   N = 3 is both, etc.
 #
 my $step = 0;
 my $stepreturn = 0;
 my %eventstops = ( "unimpinstr" => 0,
                    "nosuchlabel" => 0,
                    );
 my %watchpoints = ( );

 #
 # Mapping of the names of the instructions to the functions that evaluate them
 #
 my %instructions = (
 	add => \&add,
 	branch_not_zero => \&branch_not_zero,
 	call => \&call,
 	dec => \&dec,
 	dup => \&dup,
 	halt => \&halt,
 	output => \&output,
 	pop => \&ipop,
 	push => \&ipush,
 	return => \&ireturn,
 	var => \&var,
 	xyzzy => \&internal_end_eval,
 );

 #####################################################################
 #																	#
 #				M A I N  I N T E R P R E T E R						#
 #																	#
 #####################################################################
 #
 # Open a debug session if the command line argument is given.
 #
 start_debugger();
 send_debug_event( "started", 0 );
 debug_ui() if( $suspend );
 #
 # The main run loop
 #
 while( $run ) {
 	check_for_breakpoint();
 	debug_ui() if( $suspend );
 	yield_to_debug();
 	my $instruction = fetch_instruction();
 	increment_pc();
 	do_one_instruction($instruction);
 	if( $$currentframe{_pc_} > $#code ) {
 		$run = 0;
 	} elsif( $stepreturn ) {
 		$instruction = fetch_instruction();
 		$suspend = "step" if( is_return_instruction($instruction) );
 	}
 }
 send_debug_event( "terminated", 0 );

 sub fetch_instruction {
 	my $pc = $$currentframe{_pc_};
 	my $theinstruction = $code[$pc];
 	return $theinstruction;
 }
 sub is_return_instruction {
 	my $theinstruction = shift;
 	if( $theinstruction =~ /^:/ ) {
 		return 0;
 	} elsif( $theinstruction =~ /^#/ ) {
 		return 0;
 	} else {
 		$theinstruction =~ /^(\S+)\s*(.*)/;
 		return $1 eq "return";
 	}
 }
 sub increment_pc {
 	my $pc = $$currentframe{_pc_};
 	$pc++;
 	$$currentframe{_pc_} = $pc;
 }
 sub decrement_pc {
 	my $pc = $$currentframe{_pc_};
 	$pc--;
 	$$currentframe{_pc_} = $pc;
 }
 sub do_one_instruction {
 	my $theinstruction = shift;
 	if( $theinstruction =~ /^:/ ) {
 		# label
 		$suspend = "step" if( $step );
 	} elsif( $theinstruction =~ /^#/ ) {
 		# comment
 	} else {
 		$theinstruction =~ /^(\S+)\s*(.*)/;
 		my $op = $1;
 		my $instr = $instructions{$op};
 		if( $instr ) {
 			&$instr( $theinstruction, $2 );
 			$suspend = "step" if( $step );
 		} else {
 			send_debug_event( "unimplemented instruction $op", 1 );
 			if( $eventstops{"unimpinstr"} ) {
 				$suspend = "event unimpinstr";
 				decrement_pc();
 			}
 		}
 	}
 }

 #####################################################################
 #																	#
 #					I N S T R U C T I O N S							#
 #																	#
 #####################################################################
 sub add {
 	my $val1 = pop @stack;
 	my $val2 = pop @stack;
 	my $val = $val1 + $val2;
 	push @stack, $val;
 }

 sub branch_not_zero {
 	my $val = pop @stack;
 	if( $val ) {
 		shift;
 		my $label = shift;
 		my $dest = $labels{$label};
 		if( !defined $dest ) {
 			send_debug_event( "no such label $label", 1 );
 			if( $eventstops{"nosuchlabel"} ) {
 				$suspend = "event nosuchlabel";
 				push @stack, $val;
 				decrement_pc();
 			}
 		} else {
 			$$currentframe{_pc_} = $dest;
 		}
 	}
 }

 sub call {
 	shift;
 	my $label = shift;
 	my $dest = $labels{$label};
 	if( !defined $dest ) {
 		send_debug_event( "no such label $label", 1 );
 		if( $eventstops{"nosuchlabel"} ) {
 			$suspend = "event nosuchlabel";
 			decrement_pc();
 		}
 	} else {
 		push @frames, $currentframe;
 		$currentframe = {
 			_pc_ => $dest,
 			_func_ => $label
      	};
 	}
 }

 sub dec {
 	my $val = pop @stack;
 	$val--;
 	push @stack, $val;
 }

 sub dup {
 	my $val = pop @stack;
 	push @stack, $val;
 	push @stack, $val;
 }

 sub halt {
 	$run = 0;
 }

 sub output {
 	my $val = pop @stack;
 	print "$val\n";
 }

 sub ipop {
 	shift;
 	my $arg = shift;
 	if( $arg =~ /^\$(.*)/ ) {
 		$$currentframe{$1} = pop @stack;
 		my $key = "$$currentframe{_func_}\:\:$1";
 		if( defined $watchpoints{$key} ) {
 			if( $watchpoints{$key} & 2 ) {
 				$suspend = "watch write $key";
 			}
 		}
 	} else {
 		pop @stack;
 	}
 }

 sub ipush {
 	shift;
 	my $arg = shift;
 	if( $arg =~ /^\$(.*)/ ) {
 		my $val = $$currentframe{$1};
 		push @stack, $val;
 		my $key = "$$currentframe{_func_}\:\:$1";
 		if( defined $watchpoints{$key} ) {
 			if( $watchpoints{$key} & 1 ) {
 				$suspend = "watch read $key";
 			}
 		}
 	} else {
 		push @stack, $arg;
 	}
 }

 sub ireturn {
 	$currentframe = pop @frames;
 }

 sub var {
 	shift;
 	my $name = shift;
 	$$currentframe{$name} = 0;
 }

 #####################################################################
 #																	#
 #			D E B U G G E R  I N T E R F A C E						#
 #																	#
 #####################################################################

 sub check_for_breakpoint {
 	if( $debugflag ) {
 		my $pc = $$currentframe{_pc_};
 		if( $breakpoints[$pc] ) {
 			$suspend = "breakpoint $pc" unless $suspend eq "eval";
 		}
 	}
 }
 #
 # For each instruction, we check the debug co-routine for
 # control input. If there is input, we process it.
 #
 sub yield_to_debug {
 	if( $debugflag ) {
 		my $bytes_to_read = 1024;
 		my $bytes_read = sysread($debugsock, $debugbuf, $bytes_to_read);
 		if( defined($bytes_read) ) {
 			#print "read $bytes_to_read\n";
 			my $rin = '';
 			my $win = '';
 			my $ein = '';
     		vec($rin,fileno($debugsock),1) = 1;
 	   		$ein = $rin | $win;
 			my $debugline = $debugbuf;
 			while( !($debugline =~ /\n/) ) {
 	  				select($rin, undef, undef, undef);
 				my $bytes_to_read = 1024;
 				my $bytes_read = sysread($debugsock, $debugbuf, $bytes_to_read);
 				$debugline .= $debugbuf;
 			}
 			#print "read: $debugline";
 			process_debug_command($debugline);
 			$debugline = '';
 		} else {
 			# no bytes read
 		}
 	}
 }

 #
 # If the execution is suspended, then we go into the debug
 # ui loop, reading and processing instructions.
 #
 sub debug_ui {
 	return unless( $suspend );
 	my $pc = $$currentframe{_pc_};
 	if (!$started) {
 		send_debug_event( "suspended $suspend", 0 );
 	} else {
 		$started = 0;
 	}
    	$step = 0;
    	$stepreturn = 0;
  	my $rin = '';
 	my $win = '';
 	my $ein = '';
     vec($rin,fileno($debugsock),1) = 1;
     $ein = $rin | $win;
     my $debugline = '';
     while( $suspend ) {
 	    select($rin, undef, undef, undef);
 		my $bytes_to_read = 1024;
 		my $bytes_read = sysread($debugsock, $debugbuf, $bytes_to_read);
 		$debugline .= $debugbuf;
 		if( $debugline =~ /\n/ ) {
 			#print "read: $debugline";
 			process_debug_command($debugline);
 			$debugline = '';
 		}
     }
 	send_debug_event( "resumed step", 0 ) if( $step );
 	send_debug_event( "resumed client", 0 ) unless( $step );
 }

 sub process_debug_command {
 	my $line = shift;
 	return if( length $line < 2 );
 	my @words = split /\s/, $line;
 	my $command = lc($words[0]);
 	my $dfunc = $debug_commands{$words[0]};
 	if( $dfunc ) {
 		&$dfunc( @words );
 	}
 }

 sub debug_clear_breakpoint {
 	shift;
 	my $line = shift;
 	$breakpoints[$line] = 0;
 	print $debugsock "ok\n";
 }
 my @saved_code;
 my %saved_labels;
 my $saved_pc;
 sub debug_eval {
 	shift;
 	my $code = shift;
 	my @lines = split /\|/, $code;
 	my $newpc = scalar @code;
 	@saved_code = @code;
 	%saved_labels = %labels;
 	foreach my $line ( @lines ) {
 	   	$line =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
 		push @code, $line;
 	}
 	push @code, "xyzzy";
 	map_labels();
 	$saved_pc = $$currentframe{_pc_};
 	$$currentframe{_pc_} = $newpc;
 	print $debugsock "ok\n";
 	$suspend = 0;
 }
 sub internal_end_eval {
 	my $result = pop @stack;
 	@code = @saved_code;
 	%labels = %saved_labels;
 	$$currentframe{_pc_} = $saved_pc;
 	send_debug_event( "evalresult $result", 0 );
 	$suspend = "eval";
 }

 sub debug_data {
 	my $result = '';
 	foreach my $d ( @stack ) {
 		$result .= $d . '|';
 	}
 	print $debugsock "$result\n";
 }
 sub debug_drop_frame {
 	ireturn();
 	decrement_pc();
 	print $debugsock "ok\n";
 	send_debug_event( "resumed drop", 0 );
 	send_debug_event( "suspended drop", 0 );
 }
 sub debug_event_stop {
 	shift;
 	my $event = shift;
 	my $bool = shift;
 	$eventstops{$event} = $bool;
 	print $debugsock "ok\n";
 }
 sub debug_exit {
 	print $debugsock "ok\n";
 	send_debug_event( "terminated", 0 );
 	exit 0;
 }
 sub debug_pop {
 	pop @stack;
 	print $debugsock "ok\n";
 }
 sub debug_push {
 	shift;
 	my $value = shift;
 	push @stack, $value;
 	print $debugsock "ok\n";
 }
 sub debug_resume {
 	$suspend = 0;
 	print $debugsock "ok\n";
 }
 sub debug_set_breakpoint {
 	shift;
 	my $line = shift;
 	$breakpoints[$line] = 1;
 	print $debugsock "ok\n";
 }
 sub debug_set_data {
 	shift;
 	my $offset = shift;
 	my $value = shift;
 	$stack[$offset] = $value;
 	print $debugsock "ok\n";
 }
 sub debug_set_variable {
 	shift;
 	my $sfnumber = shift;
 	my $var = shift;
 	my $value = shift;
 	if( $sfnumber > $#frames ) {
 		$$currentframe{$var} = $value;
 	} else {
 		my $theframe = $frames[$sfnumber];
 		$$theframe{$var} = $value;
 	}
 	print $debugsock "ok\n";
 }
 sub debug_stack {
 	my $result = '';
 	foreach my $frame ( @frames ) {
 		$result .= print_frame($frame);
 		$result .= '#';
 	}
 	$result .= print_frame($currentframe);
 	print $debugsock "$result\n";
 }
 sub debug_step {
 	# set suspend to 0 to allow the debug loop to exit back to
 	# the instruction loop and thus run an instruction. However,
 	# we want to come back to the debug loop right away, so the
 	# step flag is set to true which will cause the suspend flag
 	# to get set to true when we get to the next instruction.
 	$step = 1;
 	$suspend = 0;
 	print $debugsock "ok\n";
 }
 sub debug_step_return {
 	$stepreturn = 1;
 	$suspend = 0;
 	print $debugsock "ok\n";
 }
 sub debug_suspend {
 	$suspend = "client";
 	print $debugsock "ok\n";
 }
 sub debug_var {
 	shift;
 	my $sfnumber = shift;
 	my $var = shift;
 	if( $sfnumber > $#frames ) {
 		print $debugsock "$$currentframe{$var}\n";
 	} else {
 		my $theframe = $frames[$sfnumber];
 		print $debugsock "$$theframe{$var}\n";
 	}
 }
 sub debug_watch {
 	shift;
 	my $key = shift;
 	my $value = shift;
 	$watchpoints{$key} = $value;
 	print $debugsock "ok\n";
 }
 #
 # Some event has happened so notify the debugger.
 # If there is no debugger, we may still want to report the
 # event (such as if it is an error).
 #
 sub send_debug_event {
 	my $event = shift;
 	if( $debugflag ) {
 		print $debugsock2 "$event\n";
 	} else {
 		my $use_stderr = shift;
 		print "Error: $event\n" if $use_stderr;
 	}
 }
 #
 # The stack frame output is:
 #    frame # frame # frame ...
 # where each frame is:
 #    filename | line number | function name | var | var | var | var ...
 #
 sub print_frame {
 	my $frame = shift;
 	my $result = $filename;
 	$result .= '|' . $$frame{_pc_};
 	$result .= '|' . $$frame{_func_};
 	for my $var ( keys %$frame ) {
 		$result .= '|' . $var unless( substr($var,0,1) eq '_');
 	}
 	return $result;
 }

 sub start_debugger {
   if( defined($debugflag) ) {
 	if( $debugflag eq "-debug" ) {
 		{ # make STDOUT unbuffered
 			my $ofh = select STDOUT;
 	  		$| = 1;
 	  		select $ofh;
 		}
 		$debugflag = 1;
 		$debugport = shift @ARGV;
 		$debugport2 = shift @ARGV;
 		print "-debug $debugport $debugport2\n";

 		my $mainsock = new IO::Socket::INET (LocalHost => '127.0.0.1',
                                    LocalPort => $debugport,
                                    Listen    => 1,
                                    Proto     => 'tcp',
                                    Reuse     => 1,
                                   );
 		$debugsock = $mainsock->accept();
 		my $set_it = "1";
 		my $ioctl_val = 0x80000000 | (4 << 16) | (ord('f') << 8) | 126;
 		ioctl($debugsock, $ioctl_val, $set_it) or die "couldn't set nonblocking: $^E";

 		my $mainsock2 = new IO::Socket::INET (LocalHost => '127.0.0.1',
                                    LocalPort => $debugport2,
                                    Listen    => 1,
                                    Proto     => 'tcp',
                                    Reuse     => 1,
                                   );
 		$debugsock2 = $mainsock2->accept();

 		print "debug connection accepted\n";
 	} else {
 		$debugflag = 0;
 	}
   }
 }
	#!perl.exe

	use strict;
	use warnings;
	use IO::Socket;

	#####################################################################
	# Copyright (c) 2005 IBM Corporation and others.
	# All rights reserved. This program and the accompanying materials
	# are made available under the terms of the Eclipse Public License v1.0
	# which accompanies this distribution, and is available at
	# http://www.eclipse.org/legal/epl-v10.html
	#
	# Contributors:
	# Bjorn Freeman-Benson - initial API and implementation
	#####################################################################

	#####################################################################
	# #
	# I N I T I A L I Z A T I O N A N D V A R I A B L E S #
	# #
	#####################################################################
	#
	# The push down automata stack (the data stack)
	#
	my @stack;
	#
	# Load all the code into memory
	# The code is stored as an array of strings, each line of
	# the source file being one entry in the array.
	#
	my $filename = shift;
	open INFILE, $filename or die $!;
	my @code = <INFILE>;
	close INFILE;

	my %labels;
	sub map_labels {
	#
	# A mapping of labels to indicies in the code array
	#
	%labels = ( );
	my $idx = 0;
	while( $idx <= $#code ) {
	if( length $code[$idx] > 0 ) {
	$code[$idx] =~ /^\s(.+?)\s$/;
	$code[$idx] = $1;
	$labels{$1} = $idx if( $code[$idx] =~ /^:(\S+)/ );
	} else {
	$code[$idx] = "\n";
	}
	$idx ++;
	}
	}
	map_labels();
	#
	# The stack of stack frames (the control stack)
	# Each stack frame is a mapping of variable names to values.
	# There are a number of special variable names:
	# _pc_ is the current program counter in the frame
	# the pc points to the next instruction to be executed
	# _func_ is the name of the function in this frame
	#
	my @frames;
	my $currentframe;
	$currentframe = {
	_pc_ => 0,
	_func_ => 'main'
	};

	#
	# The command line argument to start a debug session.
	#
	my $debugflag = shift;
	#
	# The port to listen for debug commands on
	# and the port to send debug events to
	#
	my $debugport;
	my $debugport2;
	#
	# The socket to listen for debug commands on
	# and the socket to send debug events on
	#
	my $debugsock;
	my $debugsock2;
	#
	# An input buffer
	#
	my $debugbuf;
	#
	# Breakpoint array
	# breakpoints are stored as a boolean for each line of code
	# if the boolean is true, there is a breakpoint on that line
	#
	my @breakpoints;
	#
	# Mapping of debugger commands to functions that evaluate them
	#
	my %debug_commands = (
	clear => \&debug_clear_breakpoint,
	data => \&debug_data,
	drop => \&debug_drop_frame,
	eval => \&debug_eval,
	eventstop => \&debug_event_stop,
	exit => \&debug_exit,
	popdata => \&debug_pop,
	pushdata => \&debug_push,
	resume => \&debug_resume,
	set => \&debug_set_breakpoint,
	setdata => \&debug_set_data,
	setvar => \&debug_set_variable,
	stack => \&debug_stack,
	step => \&debug_step,
	stepreturn => \&debug_step_return,
	suspend => \&debug_suspend,
	var => \&debug_var,
	watch => \&debug_watch
	);

	#
	# The run flag is true if the VM is running.
	# If the run flag is false, the VM exits the
	# next time the main instruction loop runs.
	#
	my $run = 1;
	#
	# The suspend flag is true if the VM should suspend
	# running the program and just listen for debug commands.
	#
	my $suspend = 0;
	my $started = 1;
	$suspend = "client" if( $debugflag );
	#
	# The step flag is used to control single-stepping.
	# See the implementation of the "step" debug command.
	# The stepreturn flag is used to control step-return.
	# The eventstops table holds which events cause suspends and which do not.
	# The watchpoints table holds watchpoint information.
	# variablename_stackframedepth => N
	# N = 0 is no watch
	# N = 1 is read watch
	# N = 2 is write watch
	# N = 3 is both, etc.
	#
	my $step = 0;
	my $stepreturn = 0;
	my %eventstops = ( "unimpinstr" => 0,
	"nosuchlabel" => 0,
	);
	my %watchpoints = ( );

	#
	# Mapping of the names of the instructions to the functions that evaluate them
	#
	my %instructions = (
	add => \&add,
	branch_not_zero => \&branch_not_zero,
	call => \&call,
	dec => \&dec,
	dup => \&dup,
	halt => \&halt,
	output => \&output,
	pop => \&ipop,
	push => \&ipush,
	return => \&ireturn,
	var => \&var,
	xyzzy => \&internal_end_eval,
	);

	#####################################################################
	# #
	# M A I N I N T E R P R E T E R #
	# #
	#####################################################################
	#
	# Open a debug session if the command line argument is given.
	#
	start_debugger();
	send_debug_event( "started", 0 );
	debug_ui() if( $suspend );
	#
	# The main run loop
	#
	while( $run ) {
	check_for_breakpoint();
	debug_ui() if( $suspend );
	yield_to_debug();
	my $instruction = fetch_instruction();
	increment_pc();
	do_one_instruction($instruction);
	if( $$currentframe{_pc_} > $#code ) {
	$run = 0;
	} elsif( $stepreturn ) {
	$instruction = fetch_instruction();
	$suspend = "step" if( is_return_instruction($instruction) );
	}
	}
	send_debug_event( "terminated", 0 );

	sub fetch_instruction {
	my $pc = $$currentframe{_pc_};
	my $theinstruction = $code[$pc];
	return $theinstruction;
	}
	sub is_return_instruction {
	my $theinstruction = shift;
	if( $theinstruction =~ /^:/ ) {
	return 0;
	} elsif( $theinstruction =~ /^#/ ) {
	return 0;
	} else {
	$theinstruction =~ /^(\S+)\s(.)/;
	return $1 eq "return";
	}
	}
	sub increment_pc {
	my $pc = $$currentframe{_pc_};
	$pc++;
	$$currentframe{_pc_} = $pc;
	}
	sub decrement_pc {
	my $pc = $$currentframe{_pc_};
	$pc--;
	$$currentframe{_pc_} = $pc;
	}
	sub do_one_instruction {
	my $theinstruction = shift;
	if( $theinstruction =~ /^:/ ) {
	# label
	$suspend = "step" if( $step );
	} elsif( $theinstruction =~ /^#/ ) {
	# comment
	} else {
	$theinstruction =~ /^(\S+)\s(.)/;
	my $op = $1;
	my $instr = $instructions{$op};
	if( $instr ) {
	&$instr( $theinstruction, $2 );
	$suspend = "step" if( $step );
	} else {
	send_debug_event( "unimplemented instruction $op", 1 );
	if( $eventstops{"unimpinstr"} ) {
	$suspend = "event unimpinstr";
	decrement_pc();
	}
	}
	}
	}

	#####################################################################
	# #
	# I N S T R U C T I O N S #
	# #
	#####################################################################
	sub add {
	my $val1 = pop @stack;
	my $val2 = pop @stack;
	my $val = $val1 + $val2;
	push @stack, $val;
	}

	sub branch_not_zero {
	my $val = pop @stack;
	if( $val ) {
	shift;
	my $label = shift;
	my $dest = $labels{$label};
	if( !defined $dest ) {
	send_debug_event( "no such label $label", 1 );
	if( $eventstops{"nosuchlabel"} ) {
	$suspend = "event nosuchlabel";
	push @stack, $val;
	decrement_pc();
	}
	} else {
	$$currentframe{_pc_} = $dest;
	}
	}
	}

	sub call {
	shift;
	my $label = shift;
	my $dest = $labels{$label};
	if( !defined $dest ) {
	send_debug_event( "no such label $label", 1 );
	if( $eventstops{"nosuchlabel"} ) {
	$suspend = "event nosuchlabel";
	decrement_pc();
	}
	} else {
	push @frames, $currentframe;
	$currentframe = {
	_pc_ => $dest,
	_func_ => $label
	};
	}
	}

	sub dec {
	my $val = pop @stack;
	$val--;
	push @stack, $val;
	}

	sub dup {
	my $val = pop @stack;
	push @stack, $val;
	push @stack, $val;
	}

	sub halt {
	$run = 0;
	}

	sub output {
	my $val = pop @stack;
	print "$val\n";
	}

	sub ipop {
	shift;
	my $arg = shift;
	if( $arg =~ /^\$(.*)/ ) {
	$$currentframe{$1} = pop @stack;
	my $key = "$$currentframe{_func_}\:\:$1";
	if( defined $watchpoints{$key} ) {
	if( $watchpoints{$key} & 2 ) {
	$suspend = "watch write $key";
	}
	}
	} else {
	pop @stack;
	}
	}

	sub ipush {
	shift;
	my $arg = shift;
	if( $arg =~ /^\$(.*)/ ) {
	my $val = $$currentframe{$1};
	push @stack, $val;
	my $key = "$$currentframe{_func_}\:\:$1";
	if( defined $watchpoints{$key} ) {
	if( $watchpoints{$key} & 1 ) {
	$suspend = "watch read $key";
	}
	}
	} else {
	push @stack, $arg;
	}
	}

	sub ireturn {
	$currentframe = pop @frames;
	}

	sub var {
	shift;
	my $name = shift;
	$$currentframe{$name} = 0;
	}

	#####################################################################
	# #
	# D E B U G G E R I N T E R F A C E #
	# #
	#####################################################################

	sub check_for_breakpoint {
	if( $debugflag ) {
	my $pc = $$currentframe{_pc_};
	if( $breakpoints[$pc] ) {
	$suspend = "breakpoint $pc" unless $suspend eq "eval";
	}
	}
	}
	#
	# For each instruction, we check the debug co-routine for
	# control input. If there is input, we process it.
	#
	sub yield_to_debug {
	if( $debugflag ) {
	my $bytes_to_read = 1024;
	my $bytes_read = sysread($debugsock, $debugbuf, $bytes_to_read);
	if( defined($bytes_read) ) {
	#print "read $bytes_to_read\n";
	my $rin = '';
	my $win = '';
	my $ein = '';
	vec($rin,fileno($debugsock),1) = 1;
	$ein = $rin \| $win;
	my $debugline = $debugbuf;
	while( !($debugline =~ /\n/) ) {
	select($rin, undef, undef, undef);
	my $bytes_to_read = 1024;
	my $bytes_read = sysread($debugsock, $debugbuf, $bytes_to_read);
	$debugline .= $debugbuf;
	}
	#print "read: $debugline";
	process_debug_command($debugline);
	$debugline = '';
	} else {
	# no bytes read
	}
	}
	}

	#
	# If the execution is suspended, then we go into the debug
	# ui loop, reading and processing instructions.
	#
	sub debug_ui {
	return unless( $suspend );
	my $pc = $$currentframe{_pc_};
	if (!$started) {
	send_debug_event( "suspended $suspend", 0 );
	} else {
	$started = 0;
	}
	$step = 0;
	$stepreturn = 0;
	my $rin = '';
	my $win = '';
	my $ein = '';
	vec($rin,fileno($debugsock),1) = 1;
	$ein = $rin \| $win;
	my $debugline = '';
	while( $suspend ) {
	select($rin, undef, undef, undef);
	my $bytes_to_read = 1024;
	my $bytes_read = sysread($debugsock, $debugbuf, $bytes_to_read);
	$debugline .= $debugbuf;
	if( $debugline =~ /\n/ ) {
	#print "read: $debugline";
	process_debug_command($debugline);
	$debugline = '';
	}
	}
	send_debug_event( "resumed step", 0 ) if( $step );
	send_debug_event( "resumed client", 0 ) unless( $step );
	}

	sub process_debug_command {
	my $line = shift;
	return if( length $line < 2 );
	my @words = split /\s/, $line;
	my $command = lc($words[0]);
	my $dfunc = $debug_commands{$words[0]};
	if( $dfunc ) {
	&$dfunc( @words );
	}
	}

	sub debug_clear_breakpoint {
	shift;
	my $line = shift;
	$breakpoints[$line] = 0;
	print $debugsock "ok\n";
	}
	my @saved_code;
	my %saved_labels;
	my $saved_pc;
	sub debug_eval {
	shift;
	my $code = shift;
	my @lines = split /\\|/, $code;
	my $newpc = scalar @code;
	@saved_code = @code;
	%saved_labels = %labels;
	foreach my $line ( @lines ) {
	$line =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	push @code, $line;
	}
	push @code, "xyzzy";
	map_labels();
	$saved_pc = $$currentframe{_pc_};
	$$currentframe{_pc_} = $newpc;
	print $debugsock "ok\n";
	$suspend = 0;
	}
	sub internal_end_eval {
	my $result = pop @stack;
	@code = @saved_code;
	%labels = %saved_labels;
	$$currentframe{_pc_} = $saved_pc;
	send_debug_event( "evalresult $result", 0 );
	$suspend = "eval";
	}

	sub debug_data {
	my $result = '';
	foreach my $d ( @stack ) {
	$result .= $d . '\|';
	}
	print $debugsock "$result\n";
	}
	sub debug_drop_frame {
	ireturn();
	decrement_pc();
	print $debugsock "ok\n";
	send_debug_event( "resumed drop", 0 );
	send_debug_event( "suspended drop", 0 );
	}
	sub debug_event_stop {
	shift;
	my $event = shift;
	my $bool = shift;
	$eventstops{$event} = $bool;
	print $debugsock "ok\n";
	}
	sub debug_exit {
	print $debugsock "ok\n";
	send_debug_event( "terminated", 0 );
	exit 0;
	}
	sub debug_pop {
	pop @stack;
	print $debugsock "ok\n";
	}
	sub debug_push {
	shift;
	my $value = shift;
	push @stack, $value;
	print $debugsock "ok\n";
	}
	sub debug_resume {
	$suspend = 0;
	print $debugsock "ok\n";
	}
	sub debug_set_breakpoint {
	shift;
	my $line = shift;
	$breakpoints[$line] = 1;
	print $debugsock "ok\n";
	}
	sub debug_set_data {
	shift;
	my $offset = shift;
	my $value = shift;
	$stack[$offset] = $value;
	print $debugsock "ok\n";
	}
	sub debug_set_variable {
	shift;
	my $sfnumber = shift;
	my $var = shift;
	my $value = shift;
	if( $sfnumber > $#frames ) {
	$$currentframe{$var} = $value;
	} else {
	my $theframe = $frames[$sfnumber];
	$$theframe{$var} = $value;
	}
	print $debugsock "ok\n";
	}
	sub debug_stack {
	my $result = '';
	foreach my $frame ( @frames ) {
	$result .= print_frame($frame);
	$result .= '#';
	}
	$result .= print_frame($currentframe);
	print $debugsock "$result\n";
	}
	sub debug_step {
	# set suspend to 0 to allow the debug loop to exit back to
	# the instruction loop and thus run an instruction. However,
	# we want to come back to the debug loop right away, so the
	# step flag is set to true which will cause the suspend flag
	# to get set to true when we get to the next instruction.
	$step = 1;
	$suspend = 0;
	print $debugsock "ok\n";
	}
	sub debug_step_return {
	$stepreturn = 1;
	$suspend = 0;
	print $debugsock "ok\n";
	}
	sub debug_suspend {
	$suspend = "client";
	print $debugsock "ok\n";
	}
	sub debug_var {
	shift;
	my $sfnumber = shift;
	my $var = shift;
	if( $sfnumber > $#frames ) {
	print $debugsock "$$currentframe{$var}\n";
	} else {
	my $theframe = $frames[$sfnumber];
	print $debugsock "$$theframe{$var}\n";
	}
	}
	sub debug_watch {
	shift;
	my $key = shift;
	my $value = shift;
	$watchpoints{$key} = $value;
	print $debugsock "ok\n";
	}
	#
	# Some event has happened so notify the debugger.
	# If there is no debugger, we may still want to report the
	# event (such as if it is an error).
	#
	sub send_debug_event {
	my $event = shift;
	if( $debugflag ) {
	print $debugsock2 "$event\n";
	} else {
	my $use_stderr = shift;
	print "Error: $event\n" if $use_stderr;
	}
	}
	#
	# The stack frame output is:
	# frame # frame # frame ...
	# where each frame is:
	# filename \| line number \| function name \| var \| var \| var \| var ...
	#
	sub print_frame {
	my $frame = shift;
	my $result = $filename;
	$result .= '\|' . $$frame{_pc_};
	$result .= '\|' . $$frame{_func_};
	for my $var ( keys %$frame ) {
	$result .= '\|' . $var unless( substr($var,0,1) eq '_');
	}
	return $result;
	}

	sub start_debugger {
	if( defined($debugflag) ) {
	if( $debugflag eq "-debug" ) {
	{ # make STDOUT unbuffered
	my $ofh = select STDOUT;
	$\| = 1;
	select $ofh;
	}
	$debugflag = 1;
	$debugport = shift @ARGV;
	$debugport2 = shift @ARGV;
	print "-debug $debugport $debugport2\n";

	my $mainsock = new IO::Socket::INET (LocalHost => '127.0.0.1',
	LocalPort => $debugport,
	Listen => 1,
	Proto => 'tcp',
	Reuse => 1,
	);
	$debugsock = $mainsock->accept();
	my $set_it = "1";
	my $ioctl_val = 0x80000000 \| (4 << 16) \| (ord('f') << 8) \| 126;
	ioctl($debugsock, $ioctl_val, $set_it) or die "couldn't set nonblocking: $^E";

	my $mainsock2 = new IO::Socket::INET (LocalHost => '127.0.0.1',
	LocalPort => $debugport2,
	Listen => 1,
	Proto => 'tcp',
	Reuse => 1,
	);
	$debugsock2 = $mainsock2->accept();

	print "debug connection accepted\n";
	} else {
	$debugflag = 0;
	}
	}
	}