Skip to main content
aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat (limited to 'org.eclipse.debug.examples.core/pdavm/pda.pl')
-rw-r--r--org.eclipse.debug.examples.core/pdavm/pda.pl678
1 files changed, 0 insertions, 678 deletions
diff --git a/org.eclipse.debug.examples.core/pdavm/pda.pl b/org.eclipse.debug.examples.core/pdavm/pda.pl
deleted file mode 100644
index de0866eba..000000000
--- a/org.eclipse.debug.examples.core/pdavm/pda.pl
+++ /dev/null
@@ -1,678 +0,0 @@
-#!perl.exe
-
-use strict;
-use warnings;
-use IO::Socket;
-
-#####################################################################
-# Copyright (c) 2005, 2008 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
-# Pawel Piech - WindRiver Systems - Bug 217211: PDA example debugger does not run on linux
-#####################################################################
-
-#####################################################################
-# #
-# 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();
-
- # make the socket non-blocking on windows
- my $set_it = "1";
- my $ioctl_val = 0x80000000 | (4 << 16) | (ord('f') << 8) | 126;
- ioctl($debugsock, $ioctl_val, $set_it);
-
- # make the socket non-blocking on linux
- $debugsock->blocking(0);
-
- 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;
- }
- }
-}

Back to the top