Index: KNOWN_ISSUES
===================================================================
RCS file: /cvs/public/parrot/KNOWN_ISSUES,v
retrieving revision 1.8
diff -u -r1.8 KNOWN_ISSUES
--- KNOWN_ISSUES 4 Feb 2003 10:24:45 -0000 1.8
+++ KNOWN_ISSUES 8 Aug 2003 16:09:11 -0000
@@ -42,7 +42,6 @@
Utilities
-- assemble.pl rolls its own packfile packing
- lib/Parrot/PackFile.pm does it's own packing & unpacking, which is
not capable of reading the dir_format=1 PBC format. Non native floats
are also not implemented.
Index: MANIFEST
===================================================================
RCS file: /cvs/public/parrot/MANIFEST,v
retrieving revision 1.394
diff -u -r1.394 MANIFEST
--- MANIFEST 8 Aug 2003 10:06:28 -0000 1.394
+++ MANIFEST 8 Aug 2003 16:09:12 -0000
@@ -13,7 +13,6 @@
RESPONSIBLE_PARTIES [main]doc
TODO [main]doc
VERSION [main]doc
-assemble.pl [devel]
bit.ops []
build_nativecall.pl []
byteorder.c []
@@ -153,7 +152,6 @@
debug.c []
debug.ops []
disassemble.c []
-disassemble.pl [devel]
docs/debug.pod [devel]doc
docs/debugger.pod [main]doc
docs/dev/byteorder.dev [main]doc
Index: assemble.pl
===================================================================
RCS file: assemble.pl
diff -N assemble.pl
--- assemble.pl 27 Jul 2003 21:03:06 -0000 1.103
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,1175 +0,0 @@
-#!/usr/bin/perl -w
-
-=head1 Parrot Assembler
-
-The Parrot Assembler's job is to take .pasm (Parrot Assembly) files and assemble
-them into Parrot bytecode. Plenty of references for Parrot assembly syntax
-already exist, so we won't go into details there. The assembler does its job
-by reading a .pasm file, extracting numeric and string constants from it, and
-reassembling the bits into bytecode.
-
-The first pass goes through and expands constants, macros, and local labels.
-Syntax is described later on, in the 'Macro' section. The next pass goes through
-and collects the numeric and string constants along with the definition points
-and PCs of labels.
-
-If you would like to view the text after the macro expansion pass, use the C<-E>
-flag. This flag simply tells the assembler to quit after the C<Macro> class
-does it thing.
-
-The final pass replaces label occurrences with the appropriate PC offset and
-accumulates the (finally completely numeric) bytecode onto the output string.
-The XS portion takes the constants and bytecode, generates a header, tacks the
-constants and bytecode on, and finally prints out the string.
-
-=head2 Macro
-
-The Parrot assembler's macro layer has now been more-or-less defined, with one
-or two additions to come. The addition of the '.' preface will hopefully make
-things easier to parse, inasmuch as everything within an assembler file that
-needs to be expanded or processed by the macro engine will have a period ('.')
-prepended to it.
-
-The macro layer implements constants, macros, and local labels. Including files
-will be done later on, but this handles most of the basic needs we have for
-macros.
-
-To create a macro, the syntax is slightly different.
-
- .macro swap (A,B,TEMP) # . marks the directive
- set .TEMP,.A # . marks the special variable.
- set .A,.B
- set .B,.TEMP
- .endm # And . marks the end of the macro.
-
-Macros support labels that are local to a given macro expansion, and the syntax
-looks something like this:
-
- .macro SpinForever (Count)
- .local $LOOP: dec .COUNT # ".local $LOOP" defines a local label.
- branch .$LOOP # Jump to said label.
- .endm
-
-Include this macro as many times as you like, and the branch statement should
-do the right thing every time. To use a global label, just as you usually do.
-
-Constants are new, and the syntax looks like:
-
- .constant PerlHash 6 # Again, . marks the directive
-
- new P0, .PerlHash # . marks the special variable for expansion.
-
-Several constants are predefined in the Macro class, but are not generated
-dynamically as they should be, at least not yet.
-
- .constant Array 0
- .constant PerlUndef 1
- ...
-
-This should be generated from include/parrot/pmc.h, but my plans are to add a
-'.include' directive so we can '.include <constants.pmc>', and let pmc2c build
-the .pmc file at the same time as it builds pmc.h.
-
-When the Assembler class is separated out, tests can use the Assembler class to
-accept a simple array of instructions and generate bytecode directly from that.
-This should eliminate the intermediary .pasm file and speed things up.
-
-=head2 Keyed access
-
- We now support the following (tested) code:
-
- new P0, .PerlHash # (See the discussion of macros above)
- set S0, "one"
- set P0[S0],1
- set I0,P0[S0]
- print I0
- print "\n"
- end
-
-=head1 COPYRIGHT
-
-Copyright (C) 2001-2003 The Perl Foundation. All Rights Reserved.
-
-=cut
-
-#
-# XXX Feel free to move this to an appropriate file when the necessary features
-# XXX have been added, and features -will- need to be added.
-#
-
-
-BEGIN {
- package Syntax;
-
- use strict;
-
- use vars qw(@ISA @EXPORT_OK $str_re $label_re $reg_re $num_re
- $bin_re $dec_re $hex_re $flt_re);
- require Exporter;
- @ISA = 'Exporter';
- @EXPORT_OK = qw($str_re $label_re $reg_re $num_re
- $bin_re $dec_re $hex_re $flt_re);
-
- $reg_re = qr([INPS]\d+);
- $bin_re = qr([-+]?0[bB][01]+);
- $dec_re = qr([-+]?\d+);
- $hex_re = qr([-+]?0[xX][0-9a-fA-F]+);
- $flt_re = qr{[-+]?\d+ (?:(?:\.\d+(?:[eE][-+]?\d+)?)
- | (?:[Ee][+-]?\d+))}x;
- $str_re = qr{" (?: \\. | (?>[^\\"]+) )* " |
- ' (?: \\. | (?>[^\\']+) )* '
- }x;
- $label_re = qr([a-zA-Z_][a-zA-Z0-9_]*);
- $num_re = qr([-+]?\d+(\.\d+([eE][-+]?\d+)?)?);
-
- # until this gets broken out into a file Syntax.pm we need to cheat:
- $INC{"Syntax.pm"} = $0;
- # Otherwise use Syntax; will attempt to require 'Syntax.pm', which will fail
-}
-
-package Macro;
-
-use Syntax qw($label_re $num_re $str_re $reg_re);
-use FindBin;
-use lib "$FindBin::Bin/lib";
-use Parrot::PMC qw(%pmc_types);
-
-=head2 Macro class
-
-=over 4
-
-=item new
-
-Create a new Macro instance. Simply take the argument list and treat it as a
-list of files to concatenate and process. Files are taken in the order that
-they appear in the argument list.
-
-=cut
-
-sub new {
- my $class = shift;
- my $self = { cur_contents => '' };
- #
- # Read the files, strip leading and trailing whitespace, and put the lines
- # into an array in $self->{cur_contents}.
- #
- for(@_) {
- open FILE,"< $_" or
- die "Couldn't open '$_' for reading: $!\n";
- while(<FILE>) {
- chomp;
- s/(^\s+|\s+$)//g;
- push @{$self->{cur_contents}},$_;
- }
- close FILE;
- }
-
- #
- #
- bless $self,$class;
- @{$self->{constants}}{keys %pmc_types} = values %pmc_types;
- $self;
-}
-
-=item _expand_macro
-
-Take a macro name and argument list, and expand the macro inline.
-Also, if the macro has embedded labels, expand these labels to local labels,
-and make certain that they're unique on a per-expansion basis. We do this with
-the C<$self->{macros}{$macro_name}{gensym}> value.
-
-=cut
-
-sub _expand_macro {
- my ($self,$macro_name,$macro_args) = @_;
- my %args;
- my @temp = @{$self->{macros}{$macro_name}{contents}};
-
- @[EMAIL PROTECTED]>{macros}{$macro_name}{arguments}}} = @$macro_args;
- $self->{macros}{$macro_name}{gensym}++;
-
- for(@temp) {
- s{\.local\s+\$($label_re):}
- {local__${macro_name}__${1}__$self->{macros}{$macro_name}{gensym}:}gxo;
-
- s{\.\$($label_re)}
- {local__${macro_name}__${1}__$self->{macros}{$macro_name}{gensym}}gxo;
- s{\.($label_re)}
- {exists $self->{constants}{$1} ? $self->{constants}{$1} : ".$1"}gexo;
- s{\.($label_re)}
- {exists $args{$1} ? $args{$1} : ".$1"}gexo;
- }
- @temp;
-}
-
-=item preprocess
-
-Preprocesses constants, macros, include statements, and eventually conditional
-compilation.
-
- .constant name {register}
- .constant name {signed_integer}
- .constant name {signed_float}
- .constant name {"string constant"}
- .constant name {'string constant'}
-
-are removed from the array. Given the line:
-
- '.constant HelloWorld "Hello, World!"'
-
-one can expand HelloWorld via:
-
- 'print .HelloWorld' # Note the period to indicate a thing to expand.
-
-Some predefined constants exist for your convenience, namely:
-
- .Array
- .PerlHash
- .PerlArray
-
-and the other PMC types.
-(This should be generated from include/parrot/pmc.h, but isn't at the moment.)
-
-The contents of external files can be included by use of the C<.include>
-macro:
-
- .include "{filename}"
-
-The contents of the included file are inserted at the point where the
-C<.include> macro occurs. This means that code like this:
-
- print "Hello "
- .include "foo.pasm"
- end
-
-where F<foo.pasm> contains:
-
- print "World \n"
-
-becomes:
-
- print "Hello "
- print "World \n"
- end
-
-Attempting to include a non-existent file is a non-fatal error.
-
- .macro name ({arguments?})
- ...
- .endm
-
-Optional arguments are simply identifiers separated by commas. These
-arguments are matched to instances inside the macro named '.foo'. A
-simple example follows:
-
- .macro inc3 (A,BLAM)
- inc .A # Mark the argument to expand with a '.'.
- inc .A
- inc .A
- print .BLAM
- .endm
-
- .inc3(I0) # Expands to the obvious ('inc I0\n') x 3
-
-=cut
-
-sub preprocess {
- my $self = shift;
- my $line = 0;
- my $in_macro;
-
- my @[EMAIL PROTECTED]>{cur_contents}};
- while(scalar(@todo)) {
- $_=shift(@todo);
- $line++;
-
- #
- # Macros aren't recursive, so shuffle them into $self->{macros}.
- #
- if($in_macro) {
- if(/^\.endm/) {
- $in_macro = undef;
- }
- else {
- push @{$self->{macros}{$in_macro}{contents}},$_;
- }
- next;
- }
-
- if(/^\.constant \s+
- ($label_re) \s+
- ($reg_re)/xo) { # .constant {name} {register}
- $self->{constants}{$1} = $2;
- }
- elsif(/^\.constant \s+
- ($label_re) \s+
- ($num_re)/xo) { # .constant {name} {number}
- $self->{constants}{$1} = $2;
- }
- elsif(/^\.constant \s+
- ($label_re) \s+
- ($str_re)/xo) { # .constant {name} {string}
- $self->{constants}{$1} = $2;
- }
- elsif(/^\.include \s+
- "([^"]+)"
- /x) { # .include "{file}"
- if(-e $1) {
- open FOO,"< $1";
- my @include;
- while(<FOO>) {
- chomp;
- s/(^\s+|\s+$)//g; # Need to strip leading & trailing whitespace
- push(@include,$_);
- }
- unshift(@todo,@include);
- close FOO;
- }
- else {
- print STDERR "Couldn't open '$1' for inclusion at line $line: $!.\n";
- }
- }
- elsif(/^\.macro \s+
- ($label_re) \s*
- \(([^)]*)\)
- /xo) { # .{name} (...
- if($in_macro) {
- push @{$self->{contents}},$_;
- print STDERR
- "Macro '$1' defined within macro '$in_macro' at line $line.\n";
- }
- else {
- $in_macro = $1;
- my @arguments = split /,/,$2;
- s/(^\s+|\s+$)//g for @arguments;
- $self->{macros}{$in_macro}{arguments} = [EMAIL PROTECTED];
- }
- }
-#
-# XXX Need a definition of how a local label in global scope should work
-#
-# elsif(/^\.local\s+\$(\w+)/) {
-# s{^\.local\s+\$(\w+)}
-# {"global.$1.$self->{global}{gensym}"}gex;
-# push @{$self->{contents}},$_;
-# }
- elsif(/^\.endm/) {
- $in_macro = undef;
- push @{$self->{contents}},$_;
- print STDERR "Macro termination outside macro at line $line.\n";
- }
-#
-# XXX Need a definition of how a local label in global scope should work
-#
-# elsif(/\.\$(\w+)/) {
-# s{\.\$(\w+)}
-# {global.$1.$self->{global}{gensym}}gx;
-# push @{$self->{contents}},$_;
-# }
- elsif(/\.($label_re) \s*
- \(([^)]*)\)/xo) { # .{name} (...
- if(defined $self->{macros}{$1}) {
- my $macro_name = $1;
- my $arguments = $2;
- $arguments =~ s{\.(\w+)}
- {defined $self->{constants}{$1} ?
- $self->{constants}{$1} : ".$1"}egx;
- my @arguments = split /,/,$arguments;
- s/(^\s+|\s+$)//g for @arguments;
- push @{$self->{contents}},
- $self->_expand_macro($macro_name,[EMAIL PROTECTED]);
- }
- else {
- push @{$self->{contents}},$_;
- print STDERR "Couldn't find macro '.$1' at line $line.\n";
- }
- }
- elsif(/\.($label_re)/o) { # .{name}
- if(defined $self->{constants}{$1}) {
- push @{$self->{contents}},$_;
- $self->{contents}[-1] =~ s/\.($label_re)/$self->{constants}{$1}/g;
- }
- else {
- push @{$self->{contents}},$_;
- #
- # XXX If this should be reenabled, how do we best determine what
- # XXX a valid constant is?
- #
-# print STDERR "Couldn't find constant '.$1' at line $line\n";
- }
- }
- else {
- push @{$self->{contents}},$_;
- }
- }
-}
-
-=item contents
-
-Access the C<$self->{contents}> internal array, where the post-processed data
-is stored.
-
-=back
-
-=cut
-
-sub contents {
- my $self = shift;
- return $self->{contents};
-}
-
-1;
-
-package Assembler;
-
-use Syntax qw($str_re $label_re $reg_re $bin_re $dec_re $hex_re $flt_re);
-
-use POSIX; # Needed for strtol()
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-use Parrot::Types; # For pack_op()
-use Parrot::OpLib::core;
-use Parrot::Config;
-use Digest::Perl::MD5 qw(md5_hex);
-
-=head2 Assembler class
-
-=over 4
-
-=item new
-
-Create a new Assembler instance.
-
- To compile a list of files:
- $compiler = Assembler->new(-files=>[qw(foo.pasm bar.pasm)]);
-
- To compile an array of instructions:
- $compiler = Assembler->new(-contents=>['set S0,"foo"','print S0','end']);
-
-=cut
-
-sub new {
- my $class = shift;
- my %args = @_;
- my $self = {
- contents => [ ],
- num_constants => 0,
- ordered_constants => [ ],
- bytecode => '',
- };
- if(exists $args{-files}) {
- $self->{files} = $args{-files};
- }
- elsif(exists $args{-contents}) {
- for(@{$args{-contents}}) {
- _annotate_contents($self,$_);
- }
- }
- bless _init($self),$class;
-}
-
-=item _annotate_contents
-
-Process the array C<$self->{contents}>, and make the appropriate annotations
-in the array. For instance, it slightly munges global and local labels to make
-sure the statements fall where they should. Also, annotates the array into an
-AoA of [$statement,$lineno]. A later pass changes $lineno to $pc, once the
-arguments have been appropriately analyzed.
-
-=cut
-
-sub _annotate_contents {
- my ($self,$line) = @_;
-
- $self->{pc}++;
- return if $line=~/^\s*$/ or $line=~/^\s*#/; # Filter out the comments and blank lines
- $line=~s/^\s+//; # Remove leading whitespace
- # Doing it this way chews infinite CPU on 5.005_03. I suspect 5.6.1
- # introduces some cunning optimisation in the regexp engine to avoid
- # backtracking through the brackets with the multiple levels of *s
- #
- # $line=~s/^((?:[^'"]+|$str_re)*)#.*$/$1/; # Remove trailing comments
- #
- # This is 5.005_03 friendly:
- if ($line=~ /^(?:[^'"]+|$str_re)#/g) {
- # pos will point to the character after the #
- substr ($line, (pos $line) - 1) = '';
- }
- $line=~s/\s+\z//; # Remove trailing whitespace
- #
- # Accumulate lines that only have labels until an instruction is found.
- # XXX This could fail if a label occurs at the end of a file.
- #
- if(@{$self->{contents}} and
- $self->{contents}[-1][0] =~ /:$/) {
- $self->{contents}[-1][0] .= $line;
- }
- else {
- push @{$self->{contents}},[$line,$self->{pc}];
- }
-}
-
-=item _init
-
-Process files of assembly code, should they have been passed in. Also,
-regardless of the input to C<new()>, take the arrays of operators and load
-them into a form appropriate to parsing.
-
-=cut
-
-sub _init {
- my $self = shift;
-
- for(@$Parrot::OpLib::core::ops) {
- my $argtype = join '_',@{$_->{ARGS}}[1..$#{$_->{ARGS}}];
- $self->{fullops}->{$_->{NAME}.($argtype &&"_$argtype") } = $_->{CODE};
- }
-
- if(defined $self->{files}) {
- for my $file (@{$self->{files}}) {
- open FILE,"< $file" or
- die "Couldn't read from '$file': $!";
- while(<FILE>) {
- _annotate_contents($self,$_);
- }
- close FILE;
- }
- }
- $self;
-}
-
-=item _collect_labels
-
-Collect labels, remove their definition, and save the appropriate line numbers.
-Local labels aren't given special treatment yet.
-
-=cut
-
-sub _collect_labels {
- my $self = shift;
-
- #
- # Collect label definition points first
- #
- for(@{$self->{contents}}) {
- while($_->[0] =~ s/^(\$?$label_re)\s*:\s*,?//o) {
- my $label = $1;
- if($label=~/^\$/) {
- push @{$self->{local_labels}{$1}},$_->[1]; # Local label
- }
- else {
- die("Label $1 already exists") if($self->{global_labels}{$1});
- $self->{global_labels}{$1} = $_->[1]; # Global label
- }
- }
- }
-}
-
-=item _generate_bytecode
-
-Start out by walking the C<$self->{contents}> array. On the first pass, make
-sure that the operation requested exists. If it doesn't, yell on STDERR.
-If it does, replace the text version of the operator with its numeric index,
-and pack it into C<$self->{bytecode}>.
-
-The inner loop walks through the arguments nested within the C<$op> arrayref,
-determining what type the argument is (C<$_->[0]>), and packing in the
-appropriate code. Note that labels are precalculated, and constants have been
-packed into the appropriate areas.
-
-=cut
-
-sub _generate_bytecode {
- my $self = shift;
-
- for my $op (@{$self->{contents}}) {
- if(defined $self->{fullops}{$op->[0][0]}) {
- $op->[0][0] = $self->{fullops}{$op->[0][0]};
-
- $self->{bytecode} .= pack_op($op->[0][0]);
-
- for(@{$op->[0]}) {
- next unless ref($_) eq 'ARRAY'; # XXX Probably should loop smarter than this
- if ($_->[0] =~ /^[ispn]$/) { # Register
- $_->[1] =~ /(\d+)/;
- $self->{bytecode} .= pack_op($1);
- }
- elsif ($_->[0] =~ /^([snpk])c$/) { # String/Num/PMC/Key constant
- $self->{bytecode} .= pack_op($_->[1]);
- }
- elsif ($_->[0] eq "ic") { # Integer constant
- $self->{bytecode} .= pack_op($_->[1]);
- }
- #
- # Not sure if this is actually used...
- #
- elsif ($_->[0] eq "r") {
- my %r_types = ("I" => 0, "N"=>1, "S"=>2, "P"=>3);
- $_->[1]=~/([PSNI])(\d+)/i;
- $self->{bytecode} .= pack_op($r_types{uc $1} >> 6 + $2);
- }
- }
- }
- else {
- print STDERR "Couldn't find operator '$op->[0][0]' on line $op->[1].\n";
- }
- }
-}
-
-=item adjust_labels
-
-This works primarily on C<$self->{global_labels}>, computing offsets and getting
-things ready for the final shift. Since the values of C<$self->{global_labels}>
-correspond to line numbers, we replace the line numbers with program counter
-indices.
-
-The next pass walks the C<$self->{contents}> array, replacing the label names
-with the difference between the current PC and the label PC. Label names are
-preserved in the previous pass, which makes this possible.
-
-=cut
-
-sub _adjust_labels {
- my $self = shift;
-
- for(keys %{$self->{global_labels}}) { # XXX This probably can be moved
- $self->{global_labels}{$_} = # XXX elsewhere.
- $self->{line_to_pc}{$self->{global_labels}{$_}};
- }
-
- for my $line (@{$self->{contents}}) {
- my $cur_pc = $self->{line_to_pc}{$line->[1]};
- for(@{$line->[0]}) {
- next unless ref($_) eq 'ARRAY'; # XXX Probably should loop smarter than this
- next unless $_->[0] eq 'label';
- $_->[0] = 'ic'; # Now is an integer constant.
- $_->[1] = $self->{global_labels}{$_->[1]} - $cur_pc;
- }
- }
-}
-
-=item _string_constant
-
-Unescape special characters in the constant and add them to not one but two
-data structures. C<$self->{constants}{s}> is for fast lookup when time comes
-to substitute constants for their indices, and C<$self->{ordered_constants}>
-keeps track of constants in order of occurrence, so they can be packed
-directly into the binary format.
-
-=cut
-
-sub _string_constant {
- my ($self,$constant) = @_;
- local $_=substr($constant,0,1);
- $constant =~ s/\$/\\\$/g;
- $constant = $_ . eval("qq$constant") . $_;
- warn "Constant: $@ " if $@;
-
- my $value = substr($constant,1,length($constant)-2);
- unless(defined $self->{constants}{s}{$value}) {
- $self->{constants}{s}{$value} = $self->{num_constants}++;
- push @{$self->{ordered_constants}},['S',$value];
- }
- return ['sc',$self->{constants}{s}{$value}];
-}
-
-=item _numeric_constant
-
-Take the numeric constant and place it into both C<$self->{constants}{n}> and
-C<$self->{ordered_constants}>. The first hash lets us do fast lookup when time
-comes to replace a constant with its value. The second array maintains the
-various constants in order of first occurrence, and is ready to pack into
-the bytecode.
-
-=cut
-
-sub _numeric_constant {
- my ($self,$constant) = @_;
-
- unless(defined $self->{constants}{n}{$constant}) {
- $self->{constants}{n}{$constant} = $self->{num_constants}++;
- push @{$self->{ordered_constants}},['N',$constant];
- }
- return ['nc',$self->{constants}{n}{$constant}];
-}
-
-=item _key_constant
-
-Build a key constant and place it into both C<$self->{constants}{n}> and
-C<$self->{ordered_constants}>. The first hash lets us do fast lookup when time
-comes to replace a constant with its value. The second array maintains the
-various constants in order of first occurrence, and is ready to pack into
-the bytecode.
-
-=cut
-
-sub _key_constant {
- my ($self,$constant) = @_;
-
- $constant .= ";";
-
- my @keys;
-
- while ($constant)
- {
- if ($constant =~ s/^($bin_re);//) {
- my $val = $1; $val =~ s/0b//;
- push(@keys, 1, (strtol($val,2))[0]);
- }
- elsif ($constant =~ s/^($hex_re);//) {
- my $val = $1; $val =~ s/0x//;
- push(@keys, 1, (strtol($val,16))[0]);
- }
- elsif ($constant =~ s/^($dec_re);//) {
- push(@keys, 1, 0+$1);
- }
- elsif ($constant =~ s/^($flt_re);//) {
- push(@keys, 2, $self->_numeric_constant($1)->[1]);
- }
- elsif ($constant =~ s/^($str_re);//) {
- push(@keys, 4, $self->_string_constant($1)->[1]);
- }
- elsif ($constant =~ s/^($reg_re);//) {
- my $type = lc(substr($1,0,1));
- $type =~ tr/inps/0123/;
- push(@keys, 7 + $type, substr($1,1));
- }
- else {
- print STDERR "Couldn't parse key '$constant'.\n";
- last;
- }
- }
-
- $constant = join(";", @keys);
-
- unless(defined $self->{constants}{k}{$constant}) {
- $self->{constants}{k}{$constant} = $self->{num_constants}++;
- push @{$self->{ordered_constants}},['K',$constant];
- }
- return ['kc',$self->{constants}{k}{$constant}];
-}
-
-=item constant_table
-
-Constant table returns a hash with the length in bytes of the constant table
-and the constant table packed.
-
-=cut
-
-sub constant_table {
- my $self = shift;
-
- # XXX Some perls < 5.8.0 recognize the 'D' pack format, but it's
- # a regular double, not a long double. This is a problem.
- # Of course, the packfile format currently only supports 8 and 12 byte
- # floats anyway. This hack prevents the creation of size
- # mismatches and invalid types. Once packfile generation et al are
- # really fixed, this can go away, which is why it's here, and not
- # elsewhere.
- my $numpackformat = $PConfig{packtype_n};
- my $numpacksize = $PConfig{numvalsize};
- if ($numpackformat eq "D" and (
- not (defined $^V and $^V ge v5.8.0) or
- ($numpacksize != 8 or $numpacksize != 12)))
- {
- $numpackformat = 'd';
- $numpacksize = length pack 'd', 1;
- }
-
-
- # $constl = the length in bytes of the constant table
- my ($constl, $wordsize);
- my $const = "";
-
- $constl = $wordsize = $PConfig{'opcode_t_size'};
- my $packtype = $PConfig{'packtype_op'};
-
- for(@{$self->{constants}}) {
- # if it's a string constant.
- if ($_->[0] eq 'S') {
- # Length of the string in bytes.
- my $slen = length($_->[1]);
- # The number of bytes to fill in the last opcode_t holding the string constant.
- my $fill = ($slen % $wordsize) ? $wordsize - $slen % $wordsize : 0;
- # Length of the whole constant.
- $constl += 6 * $wordsize + $slen + $fill;
- # Constant type, S
- $const .= pack($packtype,0x73);
- # The size of the Parrot string.
- $const .= pack($packtype, 3 * $wordsize + $slen + $fill + $wordsize);
- # Flags
- $const .= pack($packtype,0x0);
- # Encoding
- $const .= pack($packtype,0x0);
- # Type
- $const .= pack($packtype,0x0);
- # Length of string alone in bytes
- $const .= pack($packtype,$slen);
- # The string it self.
- $const .= $_->[1] . "\0" x $fill;
- }
- # if it's a float constant.
- elsif ($_->[0] eq 'N') {
- # The size of the whole constant.
- $constl += 2 * $wordsize + $numpacksize;
- # Constant type, N
- $const .= pack($packtype,0x6e);
- # Sizeof the Parrot floatval.
- $const .= pack($packtype,$numpacksize);
- # The number if self.
- $const .= pack($numpackformat,$_->[1]);
- }
- # if it's a key constant.
- elsif ($_->[0] eq 'K') {
- my @values = split(/;/, $_->[1]);
- my $values = @values;
- # The size of the whole constant;
- $constl += 3 * $wordsize + $values * $wordsize;
- # Constant type, K
- $const .= pack($packtype,0x6b);
- # Size of the packed key.
- $const .= pack($packtype,$wordsize + $values * $wordsize);
- # Number of key components
- $const .= pack($packtype,$values / 2);
- # The key atoms themselves as type and value pairs.
- for(@values) {
- $const .= pack($packtype,$_);
- }
- }
- }
-
- return ('table' => $const,
- 'length' => $constl,
- 'floattype' => ($numpacksize == 12) ? 0x01 : 0x00);
-}
-
-=item output_bytecode
-
-Returns a string with the Packfile.
-
-First process the constants and generate the constant table to be able to make
-the packfile header, then return all.
-
-=cut
-
-sub _fingerprint {
- my $fingerprint = md5_hex join "\n", map {
- join '_', $_->{NAME}, @{$_->{ARGS}}
- } @$Parrot::OpLib::core::ops;
- my @arr = ();
- for my $i (0..9) {
- push @arr, hex substr ($fingerprint, $i*2, 2);
- }
- return @arr;
-}
-
-sub output_bytecode {
- my $self = shift;
- my $wordsize;
-
- $wordsize = $PConfig{'opcode_t_size'};
- my $packtype = $PConfig{'packtype_op'};
-
- my %const_table = constant_table($self);
-
- my $byteorder = (substr($PConfig{'byteorder'},0,1) == 1) ? 0 : 1;
- my $major = $PConfig{MAJOR};
- # during devel, we check PATCH too
- my $minor = $PConfig{MINOR} | $PConfig{PATCH};
-
-
- my $packfile_header = {
- wordsize => $wordsize, # unsigned char wordsize
- byteorder => $byteorder, # unsigned char byteorder
- major => $major, # unsigned char major
- minor => $minor, # unsigned char minor
-
- flags => 0x00, # unsigned char flags
- floattype => $const_table{'floattype'}, # unsigned char floattype
- pad => [ _fingerprint ],
-
- magic => 0x0131_55a1, # opcode_t magic
- opcodetype => 0x5045_524c, # opcode_t opcodetype
- fixup_ss => 0x0000_0000, # opcode_t fixup_ss
- const_ss => $const_table{'length'}, # opcode_t const_ss
- bytecode_ss => $self->{num_constants}, # opcode_t bytecode_ss
- };
-
- my $packfile_string = "CCCCCC".("C"x10).$packtype x5;
-
- return pack($packfile_string,
- $packfile_header->{wordsize}, # C
- $packfile_header->{byteorder}, # C
- $packfile_header->{major}, # C
- $packfile_header->{minor}, # C
- $packfile_header->{flags}, # C
- $packfile_header->{floattype}, # C
- @{$packfile_header->{pad}}, # "C" x 10
- $packfile_header->{magic},
- $packfile_header->{opcodetype},
- $packfile_header->{fixup_ss},
- $packfile_header->{const_ss},
- $packfile_header->{bytecode_ss}) .
- $const_table{'table'} .
- pack ($packtype,length($self->{bytecode})) .
- $self->{bytecode};
-}
-
-=item to_bytecode
-
-Take the content array ref and turn it into a ragged AoAoA of operations with
-attached processed arguments. This is the core of the assembler.
-
- The transformation looks roughly like this:
-
- [ [ 'if I0,BLAH', 3],
- [ 'set P1[S5],P0["foo"]', 5],
- [ 'BLAH: end', 6],
- ]
-
- into:
-
- [ [ [ 'if_i_ic',
- ['i','I0'],
- ['label','BLAH'], # Leave the name here so we can resolve backward refs.
- ],
- 3, # Line number
- ],
- [ [ 'set_p_s_p_sc',
- ['p','P1'],
- ['s','S5'],
- ['p','P0'],
- ['sc',0], # String constant number 0
- ]
- 5,
- ],
- [ [ 'end',
- ],
- 6,
- ]
-
-The first pass collects labels, so we can resolve forward label references
-(That is, labels used before they're defined). References to labels aren't yet
-expanded.
-
-The second pass takes the arguments in each line (C<$_->[0]>) and breaks them
-into their components. It does this by passing each line through a loop of REs
-to break lines into each argument type. The individual REs break down the
-arguments into an array ref C<[$type,$argument]>. Constants are collected and
-replaced with indices, and the number of arguments is counted and added to the
-internal PC tracking.
-
-The third pass takes labels and replaces them with the PC offset to the actual
-instruction, and generates bytecode. It returns the bytecode, and we're done.
-
-=back
-
-=cut
-
-sub to_bytecode {
- my $self = shift;
-
- my $pc = 0;
-
- $self->_collect_labels(); # Collect labels in a separate pass
-
- for(@{$self->{contents}}) {
- #
- # Collect the operator
- #
- my $temp = $_->[0];
- my $suffixes = '';
- $temp=~s/^(\w+)\s*//;
- $_->[0] = [$1];
-
- while($temp ne '') {
- $temp=~s/^\s*(,\s*)?//;
- if($temp=~s/^#.*//) {
- # Skip flying comments.
- }
- elsif($temp=~s/^($reg_re)//o) {
- my $reg_idx = substr($1,1);
- unless($reg_idx >= 0 and $reg_idx <= 31) {
- print STDERR "Caught out-of-bounds register $1 at line $_->[1].\n";
- last;
- }
- $suffixes .= "_".lc(substr($1,0,1));
- push @{$_->[0]}, [lc(substr($1,0,1)),$1];
- }
- elsif($temp=~s/^\[(P\d+)\]//) { # P1[P0]
- my $reg_idx = substr($1,1);
- unless($reg_idx >= 0 and $reg_idx <= 31) {
- print STDERR "Caught out-of-bounds register $1 at line $_->[1].\n";
- last;
- }
- $suffixes .= "_k";
- push @{$_->[0]}, ['p',$1];
- }
- elsif($temp=~s/^\[(I\d+)\]//) { # P2[I1]
- my $reg_idx = substr($1,1);
- unless($reg_idx >= 0 and $reg_idx <= 31) {
- print STDERR "Caught out-of-bounds register $1 at line $_->[1].\n";
- last;
- }
- $suffixes .= "_ki";
- push @{$_->[0]}, ['i',$1];
- }
- elsif($temp=~s/^\[($bin_re)\]//o) { # P3[0b11101]
- my $val = $1;$val=~s/0b//;
- $suffixes .= "_kic";
- push @{$_->[0]}, ['ic',(strtol($val,2))[0]];
- }
- elsif($temp=~s/^\[($hex_re)\]//) { # P7[0x1234]
- $suffixes .= "_kic";
- push @{$_->[0]}, ['ic',(strtol($1,16))[0]];
- }
- elsif($temp=~s/^\[($dec_re)\]//) { # P14[3]
- $suffixes .= "_kic";
- push @{$_->[0]}, ['ic',0+$1];
- }
- elsif($temp=~s/^\[([^]]+)\]//) { # P18[3;2]
- $suffixes .= "_kc";
- push @{$_->[0]}, $self->_key_constant($1);
- }
- elsif($temp=~s/^($flt_re)//) {
- $suffixes .= "_nc";
- push @{$_->[0]}, $self->_numeric_constant($1);
- }
- elsif($temp=~s/^($bin_re)//o) { # 0b1101
- my $val = $1;$val=~s/0b//;
- $suffixes .= "_ic";
- push @{$_->[0]}, ['ic',(strtol($val,2))[0]];
- }
- elsif($temp=~s/^($hex_re)//o) { # 0x12aF
- $suffixes .= "_ic";
- push @{$_->[0]}, ['ic',(strtol($1,16))[0]];
- }
- elsif($temp=~s/^($dec_re)//o) { # -32
- $suffixes .= "_ic";
- push @{$_->[0]}, ['ic',0+$1];
- }
- elsif($temp=~s/^($str_re)//o) { # "Hello World"
- $suffixes .= "_sc";
- push @{$_->[0]}, $self->_string_constant($1);
- }
- elsif($temp=~s/^($label_re)//o) {
- unless(defined $self->{global_labels}{$1}) {
- print STDERR "Couldn't find global label '$1' at line $_->[1].\n";
- last;
- }
- $suffixes .= "_ic";
- push @{$_->[0]}, ['label',$1];
- }
- else {
- print STDERR "Couldn't parse argument '$temp' at line $_->[1].\n";
- last;
- }
- }
- $_->[0][0] .= $suffixes
- unless $_->[0][0] =~ /\Q$suffixes\E$/;
-# unless defined $self->{fullops}{$_->[0][0]};
- $self->{line_to_pc}{$_->[1]}=$pc;
- $pc += scalar @{$_->[0]};
- }
- $self->_adjust_labels(); # XXX It's possible that these passes could be
- $self->_generate_bytecode(); # XXX merged, but I'm not going to worry about
- # XXX it right now.
-
- return output_bytecode({
- bytecode => $self->{bytecode},
- constants => $self->{ordered_constants},
- num_constants => $self->{num_constants}
- });
-}
-
-
-package main;
-
-use strict;
-
-my %args;
-my @files;
-
-process_args(\%args,[EMAIL PROTECTED]);
-
-my $macro = Macro->new(@files);
-
-#
-# Run the files through the preprocessor, and if -E flag encountered,
-# stop right there.
-#
-$macro->preprocess();
-if(exists $args{-E}) {
- print join "\n",@{$macro->contents()};
- print "\n";
- exit;
-}
-
-#
-# Compile the files, and handle the output.
-#
-my $compiler = Assembler->new('-contents' => $macro->contents());
-my $bytecode = $compiler->to_bytecode();
-
-exit if exists $args{-c};
-if(exists $args{-o}) {
- open FILE,">$args{-o}"
- or die "Could not write to '$args{-o}': $!";
- binmode FILE;
- print FILE $bytecode;
- close FILE;
-}
-else {
- binmode STDOUT;
- print $bytecode;
-}
-
-exit;
-
-#------------------------------------------------------------------------------
-
-=over 4
-
-=item process_args
-
-Process the argument list and return the list of arguments and files to
-process. Only legal and sane arguments and files should get past this point.
-
-=back
-
-=cut
-
-sub process_args {
- my ($args,$files) = @_;
-
- while (my $arg = shift @ARGV) {
- if($arg =~ /^-(c|-checksyntax)$/) { $args->{-c} = 1; }
- elsif($arg =~ /^-E$/) { $args->{-E} = 1; }
- elsif($arg =~ /^-(o|-output)$/) { $args->{-o} = shift @ARGV; }
- elsif($arg =~ /^-(h|-help)$/) { Usage(); exit 0; }
- elsif($arg =~ /^-./) { Fail("Invalid option '$arg'\n"); }
- else { push @$files,$arg; }
- }
- Fail("No files to process.\n") unless(@$files);
- Fail("File '$_' does not exist.\n") for grep { not (-e or /^-$/) } @$files;
-}
-
-sub Fail {
- print STDERR @_;
- Usage();
- exit 1;
-}
-
-sub Usage {
- print <<" _EOF_";
-
-usage: $0 [options] file [file...]
-
- -E Preprocess input files and terminate processing
- -h,--help Print this message
- -o,--output Write file
- -c,--checksyntax Check syntax only, do not generate bytecode
-
- _EOF_
-}
Index: disassemble.pl
===================================================================
RCS file: disassemble.pl
diff -N disassemble.pl
--- disassemble.pl 27 Jul 2003 21:03:06 -0000 1.24
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,330 +0,0 @@
-#! /usr/bin/perl -w
-#
-# disassemble.pl
-#
-# Turn a parrot bytecode file into text.
-#
-# Copyright (C) 2001-2003 The Perl Foundation. All rights reserved.
-# This program is free software. It is subject to the same license
-# as the Parrot interpreter.
-#
-# $Id: disassemble.pl,v 1.24 2003/07/27 21:03:06 chromatic Exp $
-#
-
-use strict;
-use FindBin;
-use lib "$FindBin::Bin/lib";
-use Parrot::Config;
-
-use Parrot::OpLib::core;
-use Parrot::Op;
-
-use Parrot::Types;
-use Parrot::PackFile;
-use Parrot::PackFile::ConstTable;
-use Parrot::String;
-use Parrot::Key;
-
-use Data::Dumper;
-$Data::Dumper::Useqq = 1;
-$Data::Dumper::Terse = 1;
-$Data::Dumper::Indent = 0;
-
-use Getopt::Std;
-
-my %opts;
-
-getopts('x', \%opts);
-
-#
-# GLOBAL VARIABLES:
-#
-
-my @opcodes = @$Parrot::OpLib::core::ops;
-
-#my $opcode_fingerprint = Parrot::Opcode::fingerprint();
-
-
-#
-# dump_const_table()
-#
-
-sub dump_const_table {
- my ($pf) = @_;
-
- #
- # Check for the opcode table fingerprint:
- #
- # TODO: This is a really poor way to do this. Consider having a 'properties' table
- # as part of the file format. Then we can have whatever properties we want. Probably
- # these can be pairs of IVs as indexes into the constants table. Then we can have
- # a 'fingerprint' property if we want.
- #
-
- my $count = $pf->const_table->const_count;
-
-=no
- if ($count < 1) {
- warn "Disassembling without opcode table fingerprint (no constants)!";
- return;
- }
-
- my $type = $pf->const_table->constant(0)->type;
- if ($type ne Parrot::PackFile::Constant->type_code('PFC_STRING')) {
- $type = Parrot::PackFile::Constant->type_name($type);
- warn "Disassembling without opcode table fingerprint (first constant isn't a string; type = '$type')!";
- }
-
- my $ref = ref $pf->const_table->constant(0)->value;
- if ($ref ne 'Parrot::String') {
- warn "Cannot disassemble (malformed string as first constant; type = '$ref'!";
- }
-
- my $data = ref $pf->const_table->constant(0)->value->data;
- if ($data ne $opcode_fingerprint) {
- warn "Cannot disassemble (differing opcode table; data = '$data')!";
- }
-=cut
-
- #
- # Dump the constant table:
- #
-
- print "#\n";
- print "# Constant Type Data\n";
- print "# -------- ------------ ------------------------------\n";
-
- my $constant_num = 0;
-
- foreach ($pf->const_table->constants) {
- my $value;
- my $type = Parrot::PackFile::Constant->type_name($_->type + 0);
-
- if ($type eq 'PFC_STRING') {
- $value = Dumper($_->value->data);
- } elsif ($type eq 'PFC_KEY') {
- $value = $_->value->dump($pf->const_table);
- } else {
- $value = Dumper($_->value);
- }
-
- printf("# %8ld %-12s %-30s\n", $constant_num, $type, $value);
-
- $constant_num++;
- }
-
- print "#\n";
-}
-
-
-#
-# disassemble_byte_code()
-#
-
-my %rtype_map = (
- "i" => "I",
- "n" => "N",
- "p" => "P",
- "s" => "S",
- "k" => "K",
- "ki" => "KI",
-
- "ic" => "i",
- "nc" => "n",
- "pc" => "p",
- "sc" => "s",
- "kc" => "k",
- "kic" => "ki",
-);
-
-sub disassemble_byte_code {
- my ($pf) = @_;
-
- my $cursor = 0;
-
- my $offset=0;
- my $bytecode = defined $pf->byte_code ? $pf->byte_code : '';
- my $length = length($bytecode);
-
- my $label_counter = 0;
-
- my %pasm;
-
- #
- # Scan the byte code, storing the disasembled ops and linking
- # branch destinations to autogenerated labels.
- #
-
- while ($offset < $length) {
- my $op_start = $offset;
- my $op_code = shift_op($bytecode);
- $offset += sizeof("op");
-
- if (!defined $op_code) {
- warn "$0: Unable to get next opcode at offset $op_start!\n";
- last;
- }
-
- if (!defined $opcodes[$op_code]) {
- warn "$0: Unrecognized opcode '$op_code' at offset $op_start!\n";
- next;
- }
-
- if (exists $pasm{$op_start}) {
- $pasm{$op_start} = [ $pasm{$op_start}[0], [ $op_code ], $opcodes[$op_code]{NAME}, [ ] ];
- } else {
- $pasm{$op_start} = [ undef, [ $op_code ], $opcodes[$op_code]{NAME}, [ ] ];
- }
-
- my $arg_count = $opcodes[$op_code]->size - 1;
- my @args = ();
-
- foreach (1 .. $arg_count) {
- my $type = $rtype_map{$opcodes[$op_code]->arg_type($_)};
- my $unpack_size = sizeof($type);
-
- if (($offset + $unpack_size) > $length) {
- warn "$0: Premature end of bytecode in argument.\n";
- last;
- }
-
- my $arg = shift_arg($type, $bytecode);
-
- push @{$pasm{$op_start}[1]}, $arg;
-
- $offset += $unpack_size;
-
- if($type =~ m/^[INPS]$/) { # Register
- push @{$pasm{$op_start}[3]}, $type . $arg;
- } elsif($type eq "D") { # destination address
- my $dest = $op_start + sizeof('op') * $arg;
- if (!exists $pasm{$dest}) {
- $pasm{$dest} = [ "L" . $label_counter++, [ ], undef, [ ] ];
- } elsif (!defined $pasm{$dest}[0]) {
- $pasm{$dest}[0] = "L" . $label_counter++;
- }
- push @{$pasm{$op_start}[3]}, $pasm{$dest}[0];
- } elsif($type eq "K") { # key
- push @{$pasm{$op_start}[3]}, sprintf("[P$arg]");
- } elsif($type eq "KI") { # integer key
- push @{$pasm{$op_start}[3]}, sprintf("[I$arg]");
- } elsif($type eq "n") { # number constant
- push @{$pasm{$op_start}[3]}, sprintf("[nc:$arg]");
- } elsif($type eq "s") { # string constant
- push @{$pasm{$op_start}[3]}, sprintf("[sc:$arg]");
- } elsif($type eq "k") { # key constant
- push @{$pasm{$op_start}[3]}, sprintf("[kc:$arg]");
- } elsif($type eq "ki") { # integer key constant
- push @{$pasm{$op_start}[3]}, sprintf("[$arg]");
- } else { # constant
- push @{$pasm{$op_start}[3]}, $arg;
- }
- }
- }
-
- #
- # Print out the code:
- #
-
- printf "# WORD BYTE BYTE CODE LABEL OPERATION ARGUMENTS\n";
- printf "# -------- ---------- ------------------------------------------------ ------ --------------- --------------------\n";
-
- foreach my $pc (sort { $a <=> $b } keys %pasm) {
- my ($label, $code, $op_name, $args) = @{$pasm{$pc}};
- $label = defined $label ? "$label:" : '';
- my $words;
-
- if ($opts{x}) {
- $words = join(' ', map { sprintf "%08x", $_ } @$code);
- } else {
- $words = join(' ', map { sprintf "%08d", $_ } @$code);
- }
-
- my @print_args = ($pc / 4, $pc, $words, $label, $op_name);
-
- if ($opts{x}) {
- printf " %08x [%08x]: %-48s %-6s %-15s ", @print_args;
- } else {
- printf " %08d [%08d]: %-48s %-6s %-15s ", @print_args;
- }
-
- print join(", ", @$args), "\n";
- }
-}
-
-
-#
-# disassemble_file()
-#
-
-sub disassemble_file {
- my ($file_name) = @_;
-
- my $pf = Parrot::PackFile->new;
- $pf->unpack_file($file_name);
-
- printf "#\n";
- printf "# Disassembly of Parrot Byte Code from '%s'\n", $_;
- printf "#\n";
- printf "# Segments:\n";
- printf "#\n";
- printf "# * Wordsize: %8d bytes (%d)\n", sizeof('byte'), $pf->wordsize;
- printf "# * Byteorder: %8d bytes (%d)\n", sizeof('byte'), $pf->byteorder;
- printf "# * Major: %8d bytes (%d)\n", sizeof('byte'), $pf->major;
- printf "# * Minor: %8d bytes (%d)\n", sizeof('byte'), $pf->minor;
- printf "# * Flags: %8d bytes (%d)\n", sizeof('byte'), $pf->flags;
- printf "# * FloatType: %8d bytes (%d)\n", sizeof('byte'), $pf->floattype;
- printf "# * Fingerprint: %8d bytes (". "0x%02x," x9 . "0x%02x)\n", length($pf->pad),
- unpack("C10", $pf->pad);
- printf "# * Magic Number: %8d bytes (0x%08x)\n", sizeof('op'), $pf->magic;
- printf "# * Opcode Type: %8d bytes (0x%08x)\n", sizeof('op'), $pf->opcodetype;
- printf "# * Fixup Table: %8d bytes\n", $pf->fixup_table->packed_size;
- printf "# * Const Table: %8d bytes\n", $pf->const_table->packed_size;
- printf "# * Byte Code: %8d bytes (%d opcode_ts)\n", length($pf->byte_code), length($pf->byte_code) / sizeof('op');
-
- dump_const_table($pf);
- disassemble_byte_code($pf);
-
- undef $pf;
-
- return;
-}
-
-
-#
-# MAIN PROGRAM:
-#
-
[EMAIL PROTECTED] = qw(-) unless @ARGV;
-
-foreach (@ARGV) {
- disassemble_file($_)
-}
-
-exit 0;
-
-__END__
-
-=head1 NAME
-
-disassemble.pl - disassemble the byte code from Parrot Pack Files
-
-=head1 SYNOPSIS
-
- perl disassemble.pl FILE
-
-=head1 DESCRIPTION
-
-Disassembles the Parrot Pack Files listed on the command line, or
-from standard input if no file is named.
-
-=head1 COPYRIGHT
-
-Copyright (C) 2001-2003 The Perl Foundation. All Rights Reserved.
-
-=head1 LICENSE
-
-This program is free software. It is subject to the same license
-as the Parrot interpreter.
-
-=cut
Index: packfile.c
===================================================================
RCS file: /cvs/public/parrot/packfile.c,v
retrieving revision 1.92
diff -u -r1.92 packfile.c
--- packfile.c 28 Jul 2003 22:10:29 -0000 1.92
+++ packfile.c 8 Aug 2003 16:09:14 -0000
@@ -536,52 +536,10 @@
header->dir_format = PackFile_fetch_op(self, &cursor);
- /* old compat mode for assemble.pl */
if (header->dir_format == 0) {
-
- /*
- * Unpack the Constant Table Segment:
- */
- header->const_ss = PackFile_fetch_op(self, &cursor);
- self->const_table->base.op_count = header->const_ss /
- sizeof(opcode_t);
- if (!PackFile_check_segment_size(header->const_ss,
- "constant")) {
- return 0;
- }
-
- if (!PackFile_ConstTable_unpack(interpreter,
- (struct PackFile_Segment *)self->const_table,
- cursor)) {
- PIO_eprintf(NULL,
- "PackFile_unpack: Error reading constant table segment!\n");
- return 0;
- }
-
- /* Segment size is in bytes => ops */
- cursor += header->const_ss/sizeof(opcode_t);
-
- /*
- * Unpack the Byte Code Segment:
- * PackFile new did generate already a default code segment
- */
-
- header->bytecode_ss = PackFile_fetch_op(self, &cursor);
-
- if (!PackFile_check_segment_size(header->bytecode_ss,
- "bytecode")) {
- return 0;
- }
- else if (header->bytecode_ss == 0) {
- /* Must have at least one instruction */
- PIO_eprintf(NULL,
- "Packfile_unpack: No bytecode present in bytecode segment.\n");
- return 0;
- }
- self->cur_cs->base.size = header->bytecode_ss / sizeof(opcode_t);
- cursor = default_unpack(interpreter,
- (struct PackFile_Segment *) self->cur_cs, cursor);
-
+ PIO_eprintf(NULL,
+ "PackFile_unpack: Dir format 0 no longer supported!\n");
+ return 0;
}
else {
/* new format use directory */
Index: config/gen/makefiles/jako.in
===================================================================
RCS file: /cvs/public/parrot/config/gen/makefiles/jako.in,v
retrieving revision 1.11
diff -u -r1.11 jako.in
--- config/gen/makefiles/jako.in 8 Jul 2003 21:42:16 -0000 1.11
+++ config/gen/makefiles/jako.in 8 Aug 2003 16:09:14 -0000
@@ -9,8 +9,8 @@
DIR=languages/jako
TOOL_DIR=../..
-ASM=$(PERL) -I ../../lib ../../assemble.pl
IMCC=../imcc/imcc${exe}
+ASM=$(IMCC) -a --output-pbc
JAKOC=$(PERL) -I lib jakoc
INTERP=../../${test_prog}
Index: config/gen/makefiles/miniperl.in
===================================================================
RCS file: /cvs/public/parrot/config/gen/makefiles/miniperl.in,v
retrieving revision 1.3
diff -u -r1.3 miniperl.in
--- config/gen/makefiles/miniperl.in 30 May 2003 17:17:02 -0000 1.3
+++ config/gen/makefiles/miniperl.in 8 Aug 2003 16:09:14 -0000
@@ -7,7 +7,8 @@
PERL=${perl}
DIR=languages/miniperl
TOOL_DIR=../..
-ASM=$(PERL) -I ../../lib ../../assemble.pl
+IMCC=../imcc/imcc${exe}
+ASM=$(IMCC) -a --output-pbc
MINIPERLC=$(PERL) miniperlc
INTERP=./${test_prog}
Index: config/gen/makefiles/perl6.in
===================================================================
RCS file: /cvs/public/parrot/config/gen/makefiles/perl6.in,v
retrieving revision 1.8
diff -u -r1.8 perl6.in
--- config/gen/makefiles/perl6.in 30 May 2003 17:17:02 -0000 1.8
+++ config/gen/makefiles/perl6.in 8 Aug 2003 16:09:14 -0000
@@ -5,7 +5,7 @@
myperl=$(PERL) -I../../lib
compile=$(myperl) prd-perl6.pl --batch --imc
imcc=..${slash}imcc${slash}imcc
-asm=$(PERL) ..${slash}..${slash}assemble.pl
+asm=$(imcc) -a --output-pbc
all: imcc perl6-config
Index: config/gen/makefiles/root.in
===================================================================
RCS file: /cvs/public/parrot/config/gen/makefiles/root.in,v
retrieving revision 1.99
diff -u -r1.99 root.in
--- config/gen/makefiles/root.in 8 Aug 2003 08:15:27 -0000 1.99
+++ config/gen/makefiles/root.in 8 Aug 2003 16:09:14 -0000
@@ -161,7 +161,6 @@
# Make directory; do not die if dir exists.
MKDIR = $(PERL) -e ${PQ}-d or mkdir $$_,0777 or die foreach @ARGV${PQ}
-
###############################################################################
#
# BUILD TARGET CONFIGURATIONS:
@@ -328,7 +327,7 @@
#
###############################################################################
-examples/assembly/mops.pbc : examples/assembly/mops.pasm assemble.pl
+examples/assembly/mops.pbc : examples/assembly/mops.pasm
cd examples && cd assembly && $(MAKE) mops.pbc PERL=$(PERL) && cd .. && cd ..
examples/assembly/mops.c : examples/assembly/mops.pbc pbc2c.pl
@@ -337,7 +336,7 @@
examples/assembly/mops${exe} : examples/assembly/mops$(O) $(LIBPARROT)
$(LINK) $(LINKFLAGS) ${ld_out}examples/assembly/mops${exe} examples/assembly/mops$(O) $(LIBPARROT) $(C_LIBS)
-examples/assembly/life.pbc : examples/assembly/life.pasm assemble.pl
+examples/assembly/life.pbc : examples/assembly/life.pasm
cd examples && cd assembly && $(MAKE) life.pbc PERL=$(PERL) && cd .. && cd ..
examples/assembly/life.c : examples/assembly/life.pbc pbc2c.pl
@@ -583,7 +582,7 @@
$(PERL) t/harness $(EXTRA_TEST_ARGS) -b $(TEST_PROG_ARGS) quick
# Common prep for all test targets
-test_prep : $(LIBPARROT) $(IMCC_PROG) assemble.pl
+test_prep : $(LIBPARROT) $(IMCC_PROG)
test_dummy :
$(PERL) t/harness $(EXTRA_TEST_ARGS) $(TEST_PROG_ARGS)
Index: docs/intro.pod
===================================================================
RCS file: /cvs/public/parrot/docs/intro.pod,v
retrieving revision 1.15
diff -u -r1.15 intro.pod
--- docs/intro.pod 27 Jul 2003 17:57:04 -0000 1.15
+++ docs/intro.pod 8 Aug 2003 16:09:14 -0000
@@ -319,15 +319,22 @@
some time. This is only because Parrot doesn't currently have a "sleep"
op; we'll see how to implement one later on.
-How do we run this? First, we need to assemble this into Parrot
-bytecode, with the F<assemble.pl> provided. So, copy the assembler to a
+How do we run this? Copy the assembler to a
file F<showtime.pasm>, and inside your Parrot directory, run:
- perl assemble.pl showtime.pasm > showtime.pbc
+ parrot showtime.pasm
+This will assemble and run the code in F<showtime.pasm>. You can also
+create an assembled bytecode from the assembler by running:
+
+ parrot showtime.pasm -o showtime.pbc
(C<.pbc> is the file extension for Parrot bytecode.)
+To run this bytecode type
+
+ parrot showtime.pbc
+
=head2 Finding a Fibonacci number
The Fibonacci series is defined like this: take two numbers, 1 and 1.
@@ -405,8 +412,7 @@
F<languages/jako> subdirectory:
% languages/jako/jakoc fib.jako > fib.pasm
- % perl assemble.pl fib.pasm > fib.pbc
- % ./parrot fib.pbc
+ % ./parrot fib.pasm
The first 20 fibonacci numbers are:
1
1
Index: docs/running.pod
===================================================================
RCS file: /cvs/public/parrot/docs/running.pod,v
retrieving revision 1.14
diff -u -r1.14 running.pod
--- docs/running.pod 27 Jul 2003 23:51:35 -0000 1.14
+++ docs/running.pod 8 Aug 2003 16:09:14 -0000
@@ -48,18 +48,6 @@
C<parrot> also has several debugging and tracing flags; see the
usage description (generated by C<parrot -h>) for details.
-=item C<assemble.pl>
-
-Converts a Parrot assembly file to Parrot bytecode.
-
- perl assemble.pl foo.pasm > foo.pbc
-
-Usage information: C<assemble.pl -h>. Detailed documentation on the
-underlying module can be read with C<perldoc -F lib/Parrot/Assembler.pm>.
-
-This Perl-based assembler has become obsolete and may be removed at some
-point in the future.
-
=item C<optimizer.pl>
Performs some basic optimizations on Parrot assembly files. Use it by running
Index: examples/assembly/Makefile
===================================================================
RCS file: /cvs/public/parrot/examples/assembly/Makefile,v
retrieving revision 1.4
diff -u -r1.4 Makefile
--- examples/assembly/Makefile 30 May 2003 17:17:06 -0000 1.4
+++ examples/assembly/Makefile 8 Aug 2003 16:09:15 -0000
@@ -9,4 +9,4 @@
rm -f *.pbc mops.c mops.o mops
.pasm.pbc:
- $(PERL) -I../../lib ../../assemble.pl -o $@ $<
+ ../../parrot -o $@ $<
Index: examples/assembly/uniq.pasm
===================================================================
RCS file: /cvs/public/parrot/examples/assembly/uniq.pasm,v
retrieving revision 1.3
diff -u -r1.3 uniq.pasm
--- examples/assembly/uniq.pasm 17 Jul 2003 20:10:54 -0000 1.3
+++ examples/assembly/uniq.pasm 8 Aug 2003 16:09:15 -0000
@@ -1,7 +1,7 @@
# $Id: uniq.pasm,v 1.3 2003/07/17 20:10:54 scog Exp $
# uniq - Remove duplicate lines from a sorted file
#
-# % ./assemble.pl uniq.pasm -o uniq.pbc
+# % ./parrot uniq.pasm -o uniq.pbc
# % ./parrot uniq.pbc data.txt
# % ./parrot uniq.pbc -c data.txt
#
Index: languages/BASIC/interpreter/basic.pl
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/interpreter/basic.pl,v
retrieving revision 1.1
diff -u -r1.1 basic.pl
--- languages/BASIC/interpreter/basic.pl 9 Mar 2003 23:08:58 -0000 1.1
+++ languages/BASIC/interpreter/basic.pl 8 Aug 2003 16:09:16 -0000
@@ -102,5 +102,5 @@
close(T);
unlink "basic.pbc";
-system("perl -I../../../lib ../../../assemble.pl -o basic.pbc merged_basic.pasm");
+system("../../../parrot -o basic.pbc merged_basic.pasm");
system("../../../parrot basic.pbc");
Index: languages/cola/README
===================================================================
RCS file: /cvs/public/parrot/languages/cola/README,v
retrieving revision 1.15
diff -u -r1.15 README
--- languages/cola/README 24 Jun 2003 23:53:29 -0000 1.15
+++ languages/cola/README 8 Aug 2003 16:09:17 -0000
@@ -180,10 +180,7 @@
parrot a.pbc
- You can also see the Parrot assembly in "a.pasm" which should be compilable
- with the reference assembler:
-
- assemble.pl a.pasm > a.pbc
+ You can also see the Parrot assembly in "a.pasm".
Currently colac is a short Perl pre-processor that includes
classes for any import statements (using System;)
Index: languages/imcc/main.c
===================================================================
RCS file: /cvs/public/parrot/languages/imcc/main.c,v
retrieving revision 1.38
diff -u -r1.38 main.c
--- languages/imcc/main.c 8 Aug 2003 08:44:24 -0000 1.38
+++ languages/imcc/main.c 8 Aug 2003 16:09:17 -0000
@@ -75,6 +75,7 @@
" -v --verbose\n"
" -E --pre-process-only\n"
" -o --output=FILE\n"
+ " --output-pbc\n"
" -O --optimize[=LEVEL]\n"
" -a --pasm\n"
" -c --pbc\n"
@@ -108,6 +109,7 @@
#define OPT_GC_DEBUG 128
#define OPT_DESTROY_FLAG 129
#define OPT_HELP_DEBUG 130
+#define OPT_PBC_OUTPUT 131
static struct longopt_opt_decl options[] = {
{ '.', '.', 0, { "--wait" } },
{ 'E', 'E', 0, { "--pre-precess-only" } },
@@ -127,6 +129,7 @@
{ 'h', 'h', 0, { "--help" } },
{ 'j', 'j', 0, { "--jit" } },
{ 'o', 'o', OPTION_required_FLAG, { "--output" } },
+ { '\0', OPT_PBC_OUTPUT, 0, { "--output-pbc" } },
{ 'p', 'p', 0, { "--profile" } },
{ 'r', 'r', 0, { "--run-pbc" } },
{ 't', 't', 0, { "--trace" } },
@@ -228,6 +231,12 @@
case 'o':
run_pbc = 0;
output = str_dup(opt.opt_arg);
+ break;
+
+ case OPT_PBC_OUTPUT:
+ run_pbc = 0;
+ write_pbc = 1;
+ if (!output) output = str_dup("-");
break;
case 'O':
Index: languages/imcc/docs/macros.pod
===================================================================
RCS file: /cvs/public/parrot/languages/imcc/docs/macros.pod,v
retrieving revision 1.4
diff -u -r1.4 macros.pod
--- languages/imcc/docs/macros.pod 7 Jul 2003 21:56:21 -0000 1.4
+++ languages/imcc/docs/macros.pod 8 Aug 2003 16:09:17 -0000
@@ -12,7 +12,7 @@
for the original F<assemble.pl> macro layer. There for the the macro
expansion at the moment only works in assembly mode, except for the
B<.include "file"> feature. Furthermore this documentation is in
-large parts copied literally from there.
+large parts copied literally from there.
The addition of the '.' preface will hopefully make things easier to
parse, inasmuch as everything within an assembler file that needs to
Index: languages/imcc/docs/operation.pod
===================================================================
RCS file: /cvs/public/parrot/languages/imcc/docs/operation.pod,v
retrieving revision 1.4
diff -u -r1.4 operation.pod
--- languages/imcc/docs/operation.pod 7 Jul 2003 21:56:21 -0000 1.4
+++ languages/imcc/docs/operation.pod 8 Aug 2003 16:09:17 -0000
@@ -255,9 +255,8 @@
=head1 Code generation
-Imcc either generates PASM output ready to get assembled by
-F<assemble.pl> or else directly generates a PBC file for running with
-parrot.
+Imcc either generates PASM or else directly generates a PBC file for
+running with parrot.
=head1 Running code
Index: languages/imcc/docs/parsing.pod
===================================================================
RCS file: /cvs/public/parrot/languages/imcc/docs/parsing.pod,v
retrieving revision 1.8
diff -u -r1.8 parsing.pod
--- languages/imcc/docs/parsing.pod 2 Aug 2003 08:53:51 -0000 1.8
+++ languages/imcc/docs/parsing.pod 8 Aug 2003 16:09:17 -0000
@@ -107,7 +107,7 @@
This allows for global constant folding beyond subroutine scope.
Local labels in different I<compilation units> with the same name are
-allowed, though running the generated PASM through F<assemble.pl>
+allowed, though assembling the generated PASM
doesn't work. Running this code inside imcc is ok.
This will probably change so that local labels are mangled to be unique.
Index: languages/imcc/docs/running.pod
===================================================================
RCS file: /cvs/public/parrot/languages/imcc/docs/running.pod,v
retrieving revision 1.10
diff -u -r1.10 running.pod
--- languages/imcc/docs/running.pod 9 Jul 2003 12:40:18 -0000 1.10
+++ languages/imcc/docs/running.pod 8 Aug 2003 16:09:17 -0000
@@ -64,12 +64,17 @@
=item -h, --help
-=item -o outputfile
+=item -o outputfile, --output=outputfile
Act like assembler. Don't run code, unless B<-r> is given too. If the
outputfile ends with B<.pbc>, a PBC file is written. If it ends with
B<.pasm>, a PASM output is generated, even from PASM input. This can be
handy to check various optimizations, including B<-Op>.
+
+=item --output-pbc
+
+Act like assembler, but always output a bytecode even though the outputfile
+does not end in B<.pbc>
=item -r, --run-pbc
Index: languages/parrot_compiler/Makefile
===================================================================
RCS file: /cvs/public/parrot/languages/parrot_compiler/Makefile,v
retrieving revision 1.4
diff -u -r1.4 Makefile
--- languages/parrot_compiler/Makefile 30 May 2003 17:17:12 -0000 1.4
+++ languages/parrot_compiler/Makefile 8 Aug 2003 16:09:17 -0000
@@ -3,7 +3,7 @@
all :
$(PERL) "-MFile::Copy=cp" -e "cp q|parrot.pasm|, q|pc.pasm|"
$(PERL) gentable.pl pc.pasm
- $(PERL) ../../assemble.pl -o pc.pbc pc.pasm
+ ../../parrot -o pc.pbc pc.pasm
clean :
rm -f core
Index: languages/perl6/perl6
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/perl6,v
retrieving revision 1.32
diff -u -r1.32 perl6
--- languages/perl6/perl6 5 Jul 2003 09:49:02 -0000 1.32
+++ languages/perl6/perl6 8 Aug 2003 16:09:17 -0000
@@ -1042,7 +1042,6 @@
- Check for core files, and optionally get backtrace
- clean up source file
- more use of Parrot::Config
-- use assemble.pl's classes directly
- filter warnings/diagnostics ...
-Wofile -W/frompat/../topat/ (grep expr)
Index: languages/perl6/doc/debugging.pod
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/doc/debugging.pod,v
retrieving revision 1.1
diff -u -r1.1 debugging.pod
--- languages/perl6/doc/debugging.pod 27 Sep 2002 02:18:50 -0000 1.1
+++ languages/perl6/doc/debugging.pod 8 Aug 2003 16:09:17 -0000
@@ -21,7 +21,7 @@
You should see the individual compilation steps and finally the output
of above program.
-If that fails, there are currently 4 steps that might be the culprit:
+If that fails, there are currently 3 steps that might be the culprit:
=over 4
@@ -29,8 +29,6 @@
=item imcc -- the intermediate compiler
-=item assemble.pl -- PASM assembler
-
=item parrot -- the parrot interpreter
=back
@@ -126,12 +124,13 @@
runs all tests through B<imcc>. This will probably be the default run option
for the next future.
-=head2 assemble.pl
+=head2 assembling the pasm
The next step is running above parrot assembly file through the
-assembler, which generates PBC (parrot byte code).
+assembler (which is again imcc running in a diffrent mode) to generate
+PBC (parrot byte code).
- perl ../../assemble.pl -o ok.pbc __eval__.pasm
+ ../imcc/imcc -o ok.pbc __eval__.pasm
This generates the binary file F<ok.pbc>, if the assembler worked.
Index: languages/regex/test.pl
===================================================================
RCS file: /cvs/public/parrot/languages/regex/test.pl,v
retrieving revision 1.12
diff -u -r1.12 test.pl
--- languages/regex/test.pl 30 May 2003 17:17:21 -0000 1.12
+++ languages/regex/test.pl 8 Aug 2003 16:09:18 -0000
@@ -187,9 +187,9 @@
sub generate_pbc {
my ($pasm, $pbc) = @_;
- my $status = system("perl $FindBin::Bin/../../assemble.pl -o $pbc $pasm");
+ my $status = system("$FindBin::Bin/../../parrot -o $pbc $pasm");
if (! defined($status) || $status) {
- die "assemble.pl failed: $!";
+ die "assemble failed: $!";
}
}
Index: lib/Parrot/Test.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Test.pm,v
retrieving revision 1.42
diff -u -r1.42 Test.pm
--- lib/Parrot/Test.pm 27 Jul 2003 17:49:05 -0000 1.42
+++ lib/Parrot/Test.pm 8 Aug 2003 16:09:18 -0000
@@ -106,12 +106,6 @@
binmode ASSEMBLY;
print ASSEMBLY $assembly;
close ASSEMBLY;
- unless($ENV{IMCC}) {
- my $cmd = "$PConfig{perl} ${directory}assemble.pl -o $by_f $as_f";
- my $exit_code = _run_command($cmd);
- $Builder->diag("'$cmd' failed with exit code $exit_code") if $exit_code;
- }
-
}
}
