release of original PDA code base

6 files changed, 1224 insertions, 0 deletions

diff --git a/org.eclipse.debug.examples.core/pdavm/pda.pl b/org.eclipse.debug.examples.core/pdavm/pda.pl
new file mode 100644
index 000000000..82829e460
--- /dev/null
+++ b/org.eclipse.debug.examples.core/pdavm/pda.pl
@@ -0,0 +1,672 @@
+#!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;
+	}
+  }
+}
diff --git a/org.eclipse.debug.examples.core/pdavm/tests/vmtest2.pda b/org.eclipse.debug.examples.core/pdavm/tests/vmtest2.pda
new file mode 100644
index 000000000..95a35f04f
--- /dev/null
+++ b/org.eclipse.debug.examples.core/pdavm/tests/vmtest2.pda
@@ -0,0 +1,48 @@
+push 6
+push 7
+push 8
+push 9
+push 10
+call sub1
+output
+call sub3
+call sub5
+push 3
+halt
+:sub2
+push 27
+return
+:sub1
+var m
+var n
+call sub2
+pop $n
+pop $m
+push $n
+push $m
+return
+# zero-based line 23
+:sub3
+push 1
+call sub4
+push 2
+call sub4
+push 3
+return
+:sub4
+push 4
+return
+# zero-based line 34
+:sub5
+var a
+var b
+var c
+pop $c
+pop $b
+call sub6
+push $a
+return
+:sub6
+var b
+pop $b
+return
diff --git a/org.eclipse.debug.examples.core/pdavm/tests/vmtest3.pda b/org.eclipse.debug.examples.core/pdavm/tests/vmtest3.pda
new file mode 100644
index 000000000..a9fcfc2a8
--- /dev/null
+++ b/org.eclipse.debug.examples.core/pdavm/tests/vmtest3.pda
@@ -0,0 +1,11 @@
+push 1
+push 2
+push 3
+foobar swish
+push 4
+add
+add
+call zippy
+add
+output
+halt
diff --git a/org.eclipse.debug.examples.core/pdavm/tests/vmtest6.pda b/org.eclipse.debug.examples.core/pdavm/tests/vmtest6.pda
new file mode 100644
index 000000000..d90a960cf
--- /dev/null
+++ b/org.eclipse.debug.examples.core/pdavm/tests/vmtest6.pda
@@ -0,0 +1,31 @@
+var a
+var b
+push 1
+pop $a
+push 2
+pop $b
+push 3
+push 4
+#
+call inner
+#
+push $a
+push 2
+add
+pop $b
+output
+#
+halt
+#
+:inner
+var a
+var c
+pop $a
+pop $c
+push $a
+push $a
+add
+return
+:other
+push 15
+return
\ No newline at end of file
diff --git a/org.eclipse.debug.examples.core/pdavm/tests/vmtest8.pda b/org.eclipse.debug.examples.core/pdavm/tests/vmtest8.pda
new file mode 100644
index 000000000..7729409c2
--- /dev/null
+++ b/org.eclipse.debug.examples.core/pdavm/tests/vmtest8.pda
@@ -0,0 +1,14 @@
+var a
+call inner
+push 1
+output
+halt
+:inner
+var b
+call inner2
+push 2
+return
+:inner2
+var c
+push 3
+return
diff --git a/org.eclipse.debug.examples.core/pdavm/tests/vmtests.pl b/org.eclipse.debug.examples.core/pdavm/tests/vmtests.pl
new file mode 100644
index 000000000..0e2f8a358
--- /dev/null
+++ b/org.eclipse.debug.examples.core/pdavm/tests/vmtests.pl
@@ -0,0 +1,448 @@
+#!perl.exe
+
+use strict;
+use warnings;
+use IO::Socket;
+
+#####################################################################
+# Copyright (c) 2004-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
+#####################################################################
+#
+# This test is designed to run on Windows:
+#
+# cd c:\eclipse\workspace\org.eclipse.debug.examples.core
+# perl pdavm\tests\vmtests.pl
+#
+# If the tests fail, they often indicate that by hanging in an
+# infinite loop. Additionally, the vm under test often becomes
+# a 100% CPU usage zombie. Use the task manager to kill them.
+#
+my $socket1;
+my $socket2;
+
+sub expect_output {
+	my $expect = shift;
+	my $line = <PROGRAM_OUTPUT>;
+	chomp($line);
+	return if( $line eq $expect );
+	die "expected output: $expect\nSaw output: $line";
+}
+sub expect_output_eof {
+	my $line = <PROGRAM_OUTPUT>;
+	return if( !defined $line );
+	die "expected: EOF on output";
+}
+sub send_command {
+	my $string = shift;
+	my $expect = shift;
+	$expect = "ok" if( !defined $expect );
+	#print STDERR "SEND: $string\n";
+	print $socket1 "$string\n";
+	my $result = <$socket1>;
+	chomp($result);
+	#print STDERR "RESULT: $result\n";
+	die "sent: $string\nexpected: $expect\nsaw:      $result" if( !($result eq $expect) );
+}
+sub expect_event {
+	my $string = shift;
+	my $event = <$socket2>;
+	chomp($event);
+	#print STDERR "EVENT: $event\n";
+	die "expected event: $string\nsaw event: $event" if( !($string eq $event) );
+}
+sub setup_sockets {
+	#print STDERR "calling socket 12345\n";
+	$socket1 = IO::Socket::INET->new(
+			Proto    => "tcp",
+			PeerAddr => "localhost",
+			PeerPort => "12345",
+			Timeout  => 10,
+		    )
+		  or die "cannot connect to debug socket 12345";
+	#print STDERR "calling socket 12346\n";
+	$socket2 = IO::Socket::INET->new(
+			Proto    => "tcp",
+			PeerAddr => "localhost",
+			PeerPort => "12346",
+			Timeout  => 10,
+		    )
+		  or die "cannot connect to debug socket 12346";
+	#print STDERR "done calling sockets\n";
+}
+
+sub test2 {
+	print "test2 (common debug commands)..\n";
+	
+	my $kidpid;
+	die "can't fork: $!" unless defined($kidpid = fork());
+	if( $kidpid ) {	
+		#print STDERR "starting program\n";
+		open PROGRAM_OUTPUT, "perl pdavm\\pda.pl pdavm\\tests\\vmtest2.pda -debug 12345 12346 |";
+		#print STDERR "done starting program\n";
+		expect_output("-debug 12345 12346");
+		expect_output("debug connection accepted");
+		expect_output("10");
+		expect_output_eof();
+		exit 0;
+	} else {
+		setup_sockets();
+		expect_event("started");
+		# test step
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		# test breakpoint
+		send_command("set 4");
+		send_command("data", "6|");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("suspended breakpoint 4");
+		# test data stack
+		send_command("data", "6|7|8|9|");
+		send_command("popdata");
+		send_command("data", "6|7|8|");
+		send_command("pushdata 11");
+		send_command("data", "6|7|8|11|");
+		send_command("setdata 1 2");
+		send_command("data", "6|2|8|11|");
+		# test call stack
+		send_command("set 12");
+		send_command("set 19");
+		send_command("stepreturn");
+		expect_event("resumed client");
+		expect_event("suspended breakpoint 12");
+		send_command("clear 19");
+		send_command("stack", "pdavm\\tests\\vmtest2.pda|6|main#pdavm\\tests\\vmtest2.pda|18|sub1|m|n#pdavm\\tests\\vmtest2.pda|12|sub2" );
+		send_command("stepreturn");
+		expect_event("resumed client");
+		expect_event("suspended step");
+		send_command("stack", "pdavm\\tests\\vmtest2.pda|6|main#pdavm\\tests\\vmtest2.pda|18|sub1|m|n#pdavm\\tests\\vmtest2.pda|13|sub2" );
+		send_command("stepreturn");
+		expect_event("resumed client");
+		expect_event("suspended step");
+		send_command("stack", "pdavm\\tests\\vmtest2.pda|6|main#pdavm\\tests\\vmtest2.pda|22|sub1|m|n" );
+		send_command("set 6");
+		send_command("stepreturn");
+		expect_event("resumed client");
+		expect_event("suspended breakpoint 6");
+		# test set and clear
+		send_command("set 27");
+		send_command("set 29");
+		send_command("set 33");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("suspended breakpoint 33");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("suspended breakpoint 27");
+		send_command("clear 33");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("suspended breakpoint 29");
+		# test var and setvar
+		send_command("set 47");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("suspended breakpoint 47");
+		send_command("var 1 b", "4");
+		send_command("var 2 b", "2");
+		send_command("var 1 a", "0");
+		send_command("setvar 1 a 99");
+		send_command("data", "6|2|8|11|27|1|4|");
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		send_command("var 1 a", "99");
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		send_command("data", "6|2|8|11|27|1|4|99|");
+		# test exit
+		send_command("exit");
+		expect_event("terminated");
+	}
+	#print STDERR "waiting for child\n";
+	wait();
+	#print STDERR "child joined\n";
+	close PROGRAM_OUTPUT;
+	print "test2..SUCCESS\n";
+}
+
+sub test3 {
+	print "test3 (uncaught events)..\n";
+	
+	my $kidpid;
+	die "can't fork: $!" unless defined($kidpid = fork());
+	if( $kidpid ) {	
+		#print STDERR "starting program\n";
+		open PROGRAM_OUTPUT, "perl pdavm\\pda.pl pdavm\\tests\\vmtest3.pda -debug 12345 12346 |";
+		#print STDERR "done starting program\n";
+		expect_output("-debug 12345 12346");
+		expect_output("debug connection accepted");
+		expect_output("10");
+		expect_output_eof();
+		exit 0;
+	} else {
+		setup_sockets();
+		expect_event("started");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("unimplemented instruction foobar");
+		expect_event("no such label zippy");
+		expect_event("terminated");
+	}
+	#print STDERR "waiting for child\n";
+	wait();
+	#print STDERR "child joined\n";
+	close PROGRAM_OUTPUT;
+	print "test3..SUCCESS\n";
+}
+sub test4 {
+	print "test4 (caught events)..\n";
+	
+	my $kidpid;
+	die "can't fork: $!" unless defined($kidpid = fork());
+	if( $kidpid ) {	
+		#print STDERR "starting program\n";
+		open PROGRAM_OUTPUT, "perl pdavm\\pda.pl pdavm\\tests\\vmtest3.pda -debug 12345 12346 |";
+		#print STDERR "done starting program\n";
+		expect_output("-debug 12345 12346");
+		expect_output("debug connection accepted");
+		expect_output("10");
+		expect_output_eof();
+		exit 0;
+	} else {
+		setup_sockets();
+		expect_event("started");
+		send_command("eventstop unimpinstr 1");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("unimplemented instruction foobar");
+		expect_event("suspended event unimpinstr");
+		send_command("eventstop unimpinstr 0");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("unimplemented instruction foobar");
+		expect_event("no such label zippy");
+		expect_event("terminated");
+	}
+	#print STDERR "waiting for child\n";
+	wait();
+	#print STDERR "child joined\n";
+	close PROGRAM_OUTPUT;
+	print "test4..SUCCESS\n";
+}
+sub test5 {
+	print "test5 (caught events)..\n";
+	
+	my $kidpid;
+	die "can't fork: $!" unless defined($kidpid = fork());
+	if( $kidpid ) {	
+		#print STDERR "starting program\n";
+		open PROGRAM_OUTPUT, "perl pdavm\\pda.pl pdavm\\tests\\vmtest3.pda -debug 12345 12346 |";
+		#print STDERR "done starting program\n";
+		expect_output("-debug 12345 12346");
+		expect_output("debug connection accepted");
+		expect_output("10");
+		expect_output_eof();
+		exit 0;
+	} else {
+		setup_sockets();
+		expect_event("started");
+		send_command("eventstop nosuchlabel 1");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("unimplemented instruction foobar");
+		expect_event("no such label zippy");
+		expect_event("suspended event nosuchlabel");
+		send_command("eventstop nosuchlabel 0");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("no such label zippy");
+		expect_event("terminated");
+	}
+	#print STDERR "waiting for child\n";
+	wait();
+	#print STDERR "child joined\n";
+	close PROGRAM_OUTPUT;
+	print "test5..SUCCESS\n";
+}
+sub test6 {
+	print "test6 (watch points)..\n";
+	
+	my $kidpid;
+	die "can't fork: $!" unless defined($kidpid = fork());
+	if( $kidpid ) {	
+		#print STDERR "starting program\n";
+		open PROGRAM_OUTPUT, "perl pdavm\\pda.pl pdavm\\tests\\vmtest6.pda -debug 12345 12346 |";
+		#print STDERR "done starting program\n";
+		expect_output("-debug 12345 12346");
+		expect_output("debug connection accepted");
+		expect_output("8");
+		expect_output_eof();
+		exit 0;
+	} else {
+		setup_sockets();
+		expect_event("started");
+		send_command("watch inner::a 1");
+		send_command("watch main::a 2");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("suspended watch write main::a");
+		send_command("stack", "pdavm\\tests\\vmtest6.pda|4|main|a|b");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("suspended watch read inner::a");
+		send_command("stack", "pdavm\\tests\\vmtest6.pda|10|main|a|b#pdavm\\tests\\vmtest6.pda|25|inner|a|c");
+		send_command("watch inner::a 0");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("terminated");
+	}
+	#print STDERR "waiting for child\n";
+	wait();
+	#print STDERR "child joined\n";
+	close PROGRAM_OUTPUT;
+	print "test6..SUCCESS\n";
+}
+sub test7 {
+	print "test7 (eval)..\n";
+	
+	my $kidpid;
+	die "can't fork: $!" unless defined($kidpid = fork());
+	if( $kidpid ) {	
+		#print STDERR "starting program\n";
+		open PROGRAM_OUTPUT, "perl pdavm\\pda.pl pdavm\\tests\\vmtest6.pda -debug 12345 12346 |";
+		#print STDERR "done starting program\n";
+		expect_output("-debug 12345 12346");
+		expect_output("debug connection accepted");
+		expect_output("8");
+		expect_output_eof();
+		exit 0;
+	} else {
+		setup_sockets();
+		expect_event("started");
+		send_command("set 25");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("suspended breakpoint 25");
+		#
+		send_command("eval push%204|push%205|add");
+		expect_event("resumed client");
+		expect_event("evalresult 9");
+		expect_event("suspended eval");
+		#
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		send_command("stack", "pdavm\\tests\\vmtest6.pda|10|main|a|b#pdavm\\tests\\vmtest6.pda|26|inner|a|c");
+ 		send_command("data", "4|4|");
+ 		send_command("eval call%20other");
+		expect_event("resumed client");
+		expect_event("evalresult 15");
+		expect_event("suspended eval");
+		send_command("stack", "pdavm\\tests\\vmtest6.pda|10|main|a|b#pdavm\\tests\\vmtest6.pda|26|inner|a|c");
+ 		send_command("data", "4|4|");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("terminated");
+	}
+	#print STDERR "waiting for child\n";
+	wait();
+	#print STDERR "child joined\n";
+	close PROGRAM_OUTPUT;
+	print "test7..SUCCESS\n";
+}
+sub test1 {
+	print "test1 (normal run mode)..\n";
+	open PROGRAM_OUTPUT, "perl pdavm\\pda.pl examples\\example.pda |" or die $!;
+	expect_output("\"hello\"");
+	expect_output("\"barfoo\"");
+	expect_output("\"first\"");
+	expect_output("\"second\"");
+	expect_output("12");
+	expect_output("11");
+	expect_output("10");
+	expect_output("\"barfoo\"");
+	expect_output("\"first\"");
+	expect_output("\"second\"");
+	expect_output("\"end\"");
+	expect_output_eof();
+	print "test1..SUCCESS\n";
+}
+sub test8 {
+	print "test8 (drop to frame)..\n";
+	
+	my $kidpid;
+	die "can't fork: $!" unless defined($kidpid = fork());
+	if( $kidpid ) {	
+		#print STDERR "starting program\n";
+		open PROGRAM_OUTPUT, "perl pdavm\\pda.pl pdavm\\tests\\vmtest8.pda -debug 12345 12346 |";
+		#print STDERR "done starting program\n";
+		expect_output("-debug 12345 12346");
+		expect_output("debug connection accepted");
+		expect_output("1");
+		expect_output_eof();
+		exit 0;
+	} else {
+		setup_sockets();
+		expect_event("started");
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		send_command("stack", "pdavm\\tests\\vmtest8.pda|2|main|a#pdavm\\tests\\vmtest8.pda|8|inner|b#pdavm\\tests\\vmtest8.pda|12|inner2|c");
+		send_command("drop");
+		expect_event("suspended drop");
+		send_command("stack", "pdavm\\tests\\vmtest8.pda|2|main|a#pdavm\\tests\\vmtest8.pda|7|inner|b");
+		send_command("step");
+		expect_event("resumed step");
+		expect_event("suspended step");
+		send_command("stack", "pdavm\\tests\\vmtest8.pda|2|main|a#pdavm\\tests\\vmtest8.pda|8|inner|b#pdavm\\tests\\vmtest8.pda|10|inner2");
+		send_command("resume");
+		expect_event("resumed client");
+		expect_event("terminated");
+	}
+	#print STDERR "waiting for child\n";
+	wait();
+	#print STDERR "child joined\n";
+	close PROGRAM_OUTPUT;
+	print "test8..SUCCESS\n";
+}
+
+#
+# Run the tests
+#
+test1();
+test2();
+test3();
+test4();
+test5();
+test6();
+test7();
+test8();
+print "All tests complete\n";
\ No newline at end of file