Author: bernhard
Date: Thu May 5 07:06:34 2005
New Revision: 7984
Added:
trunk/languages/urm/lib/
trunk/languages/urm/lib/URM/
trunk/languages/urm/lib/URM/Test.pm (contents, props changed)
trunk/languages/urm/t/harness
- copied, changed from rev 7981, trunk/languages/urm/t/t.pl
trunk/languages/urm/t/in_out.t
trunk/languages/urm/t/mmu.t
- copied, changed from rev 7981, trunk/languages/urm/t/testmmu.urm
trunk/languages/urm/t/syn.t
- copied, changed from rev 7981, trunk/languages/urm/t/testpars.urm
Removed:
trunk/languages/urm/t/t.pl
trunk/languages/urm/t/testmmu.urm
trunk/languages/urm/t/testmmu2.urm
trunk/languages/urm/t/testmmu3.urm
trunk/languages/urm/t/testpars.urm
Modified:
trunk/MANIFEST
trunk/config/gen/makefiles/m4.in
trunk/config/gen/makefiles/parrot_compiler.in
trunk/config/gen/makefiles/scheme.in
trunk/config/gen/makefiles/urm.in
trunk/languages/parrot_compiler/t/harness
trunk/languages/scheme/Scheme/Test.pm
trunk/languages/testall
trunk/languages/urm/INSTALL
trunk/languages/urm/README
trunk/languages/urm/urmc
Log:
Convert the tests of 'languages/urm' to a more standard test suite,
by adding urm/t/harness and url/lib/URM/Test.pm
Add urm to unified languages testing with 'make languages-test'
BUGFIX: urm: Recognize output register when it is defined is same line
as the input registers.
Change: Fill input registers from command line, not by prompting the user.
This makes testing easier.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Thu May 5 07:06:34 2005
@@ -1422,11 +1422,11 @@
languages/urm/examples/mult.urm [urm]
languages/urm/examples/sim.urm [urm]
languages/urm/examples/sub.urm [urm]
-languages/urm/t/t.pl [urm]
-languages/urm/t/testmmu.urm [urm]
-languages/urm/t/testmmu2.urm [urm]
-languages/urm/t/testmmu3.urm [urm]
-languages/urm/t/testpars.urm [urm]
+languages/urm/lib/URM/Test.pm [urm]
+languages/urm/t/harness [urm]
+languages/urm/t/in_out.t [urm]
+languages/urm/t/mmu.t [urm]
+languages/urm/t/syn.t [urm]
languages/urm/urm-old.pl [urm]
languages/urm/urmc [urm]
lib/Class/Struct.pm [devel]
Modified: trunk/config/gen/makefiles/m4.in
==============================================================================
--- trunk/config/gen/makefiles/m4.in (original)
+++ trunk/config/gen/makefiles/m4.in Thu May 5 07:06:34 2005
@@ -1,5 +1,7 @@
# $Id$
+# Makefile for languages/m4
+
# Setup of some commands
LN_SF = ln -s -f
PARROT = ../../parrot${exe}
@@ -23,10 +25,9 @@
#CONDITIONED_LINE(has_gnu_m4):USE_GNU_M4 = -use-gnu-m4
#INVERSE_CONDITIONED_LINE(has_gnu_bc):USE_GNU_M4 =
-# the default target
+default: all
all: build
-# This is a listing of all targets, that are meant to be called by users
help:
@echo ""
@echo "Following targets are available for the user:"
@@ -84,8 +85,7 @@
$(M4_EVAL_COMPILER_SO)
realclean: clean
- $(RM_RF) \
-Makefile
+ $(RM_RF) Makefile
distclean: realclean
Modified: trunk/config/gen/makefiles/parrot_compiler.in
==============================================================================
--- trunk/config/gen/makefiles/parrot_compiler.in (original)
+++ trunk/config/gen/makefiles/parrot_compiler.in Thu May 5 07:06:34 2005
@@ -1,6 +1,8 @@
# Copyright: 2001-2005 The Perl Foundation. All Rights Reserved.
# $Id$
+# Makefile for languages/parrot_compiler
+
EXE = ${exe}
LN_SF = ln -s -f
@@ -8,9 +10,9 @@
RM_F = ${rm_f}
PARROT = ../../${test_prog}$(EXE)
+default: all
all : runtime parrot.pbc parrot_compiler.pbc parrot_compiler.pasm
-# This is a listing of all targets, that are meant to be called by users
help :
@echo ""
@echo "Following targets are available for the user:"
@@ -25,7 +27,7 @@
@echo " realclean: clean up generated files"
test :
- cd .. && $(PERL) -I../lib -Iparrot_compiler/lib
parrot_compiler/t/harness
+ cd .. && $(PERL) -I../lib parrot_compiler/t/harness
clean :
$(RM_F) *.pbc
Modified: trunk/config/gen/makefiles/scheme.in
==============================================================================
--- trunk/config/gen/makefiles/scheme.in (original)
+++ trunk/config/gen/makefiles/scheme.in Thu May 5 07:06:34 2005
@@ -1,24 +1,32 @@
-#
-# Makefile
-#
+# Copyright: 2005 The Perl Foundation. All Rights Reserved.
# $Id$
-#
+# Makefile for languages/scheme
+
+# Setup of some commands
PERL = ${perl}
RM_F = ${rm_f}
-DIR=languages/scheme
-TOOL_DIR=../..
-ASM = ../../parrot
-SCHEMEC=$(PERL) schemec
-INTERP=./${test_prog}
-
-#
-# Default target:
-#
-
-default: test
-# echo "make: Makefile: no default target"
+DIR = languages/scheme
+TOOL_DIR = ../..
+ASM = ../../parrot
+SCHEMEC = $(PERL) schemec
+INTERP = ./${test_prog}
+
+default: build
+
+help :
+ @echo ""
+ @echo "Following targets are available for the user:"
+ @echo ""
+ @echo " build: Just check whether 'schemec' compiles"
+ @echo " This is the default."
+ @echo ""
+ @echo " test: run the test suite,"
+ @echo ""
+ @echo " clean: clean up temporary files"
+ @echo ""
+ @echo " realclean: clean up generated files"
foo: foo.scheme schemec
$(SCHEMEC) foo.scheme > foo.pasm
@@ -30,6 +38,9 @@
# Compilation:
#
+build:
+ $(PERL) -c schemec
+
test.pasm: test.scheme schemec
$(SCHEMEC) test.scheme > test.pasm
@@ -65,6 +76,9 @@
t/*/*.scheme \
t/*/*.out
+realclean: clean
+ $(RM_RF) Makefile
+
over:
@$(MAKE) clean
@$(MAKE) all
Modified: trunk/config/gen/makefiles/urm.in
==============================================================================
--- trunk/config/gen/makefiles/urm.in (original)
+++ trunk/config/gen/makefiles/urm.in Thu May 5 07:06:34 2005
@@ -1,20 +1,37 @@
-RM_F = ${rm_f}
-PERL = ${perl}
+# $Id$
-PARROT = ..${slash}..${slash}parrot
+# Makefile for languages/urm
-all: build
+# Setup of some commands
+RM_F = ${rm_f}
+PERL = ${perl}
+PARROT = ../../parrot
+
+default: build
+
+help :
+ @echo ""
+ @echo "Following targets are available for the user:"
+ @echo ""
+ @echo " build: Just check whether 'urmc' compiles"
+ @echo " This is the default."
+ @echo ""
+ @echo " test: run the test suite,"
+ @echo ""
+ @echo " clean: clean up temporary files"
+ @echo ""
+ @echo " realclean: clean up generated files"
test: build
- $(PERL) t${slash}t.pl
+ cd .. && $(PERL) -I../lib urm/t/harness
examples: build
- $(PERL) urmc -c examples${slash}biggerzero.urm
- $(PERL) urmc -c examples${slash}sub.urm
- $(PERL) urmc -c examples${slash}sim.urm
- $(PERL) urmc -c examples${slash}mult.urm
- $(PERL) urmc -c examples${slash}div.urm
- $(PERL) urmc -c examples${slash}distance.urm
+ $(PERL) urmc -c examples/biggerzero.urm
+ $(PERL) urmc -c examples/sub.urm
+ $(PERL) urmc -c examples/sim.urm
+ $(PERL) urmc -c examples/mult.urm
+ $(PERL) urmc -c examples/div.urm
+ $(PERL) urmc -c examples/distance.urm
build:
$(PERL) -c urmc
@@ -24,11 +41,11 @@
$(RM_F) *~ *.pasm
$(RM_F) *~
$(RM_F) \#*
- $(RM_F) examples${slash}*.pasm examples${slash}*.pbc
- $(RM_F) examples${slash}*~
- $(RM_F) examples${slash}\#*
- $(RM_F) t${slash}*.pasm t${slash}*.pbc
+ $(RM_F) examples/*.pasm examples/*.pbc
+ $(RM_F) examples/*~
+ $(RM_F) examples/\#*
+ $(RM_F) t/*.pasm t/*.urm t/*.out
-distclean: clean
+realclean: clean
$(RM_F) Makefile
Modified: trunk/languages/parrot_compiler/t/harness
==============================================================================
--- trunk/languages/parrot_compiler/t/harness (original)
+++ trunk/languages/parrot_compiler/t/harness Thu May 5 07:06:34 2005
@@ -15,8 +15,8 @@
=head1 DESCRIPTION
-If I'm called with a single
-argument of "--files", I just return a list of files to process.
+If I'm called with a single argument of "--files",
+I just return a list of files to process.
This list is one per line, and is relative to the languages dir.
If I'm called with no args, I run the complete suite.
Modified: trunk/languages/scheme/Scheme/Test.pm
==============================================================================
--- trunk/languages/scheme/Scheme/Test.pm (original)
+++ trunk/languages/scheme/Scheme/Test.pm Thu May 5 07:06:34 2005
@@ -4,7 +4,6 @@
use strict;
use vars qw(@EXPORT @ISA);
-use lib '../lib';
use Parrot::Config;
@@ -28,26 +27,26 @@
no strict 'refs';
*{"Scheme::Test::output_$meth"} = sub ($$;$) {
- my( $assembly, $output, $desc ) = @_;
+ my( $lang_code, $output, $desc ) = @_;
++$count;
- my( $scheme_f, $as_f, $by_f, $out_f ) = map { # JMG
+ my( $lang_f, $pasm_f, $by_f, $out_f ) = map { # JMG
my $t = $0; $t =~ s/\.t$/_$count\.$_/; $t
} ( qw(scheme pasm pbc out) ); # JMG
# STDERR is written into same output file
- open SCHEME, "> $scheme_f" or die "Unable to open '$scheme_f'"; # JMG
- binmode SCHEME; # JMG
- print SCHEME $assembly; # JMG
- close SCHEME; # JMG
+ open LANG, "> $lang_f" or die "Unable to open '$lang_f'"; # JMG
+ binmode LANG; # JMG
+ print LANG $lang_code; # JMG
+ close LANG; # JMG
Parrot::Test::run_command(
- "$PConfig{perl} languages/scheme/schemec languages/$scheme_f",
+ "$PConfig{perl} languages/scheme/schemec languages/$lang_f",
CD => '..', # $self->{relpath},
- STDOUT => $as_f, STDERR => $as_f,
+ STDOUT => $pasm_f, STDERR => $pasm_f,
);
Parrot::Test::run_command(
- "./parrot languages/$as_f",
+ "./parrot languages/$pasm_f",
CD => '..', # $self->{relpath},
STDOUT => $out_f, STDERR => $out_f,
);
@@ -56,7 +55,7 @@
@_ = ( $prog_output, $output, $desc );
#goto &{"Test::More::$meth"};
my $ok = &{"Test::More::$meth"}( @_ );
- # if( $ok ) { foreach my $meth ( $scheme_f, $as_f, $by_f, $out_f ) {
unlink $meth } } # JMG
+ # if( $ok ) { foreach my $meth ( $lang_f, $pasm_f, $by_f, $out_f ) {
unlink $meth } } # JMG
}
}
Modified: trunk/languages/testall
==============================================================================
--- trunk/languages/testall (original)
+++ trunk/languages/testall Thu May 5 07:06:34 2005
@@ -66,9 +66,8 @@
# ruby No t/harness
# tcl No t/harness
#my @unified_testable_languages = qw( tcl );
-# urm No t/harness
-my @unified_testable_languages = qw( m4 parrot_compiler scheme );
+my @unified_testable_languages = qw( m4 parrot_compiler scheme urm );
my @harnesses =
grep {-f $_}
map { File::Spec->join($_,"t","harness") }
Modified: trunk/languages/urm/INSTALL
==============================================================================
--- trunk/languages/urm/INSTALL (original)
+++ trunk/languages/urm/INSTALL Thu May 5 07:06:34 2005
@@ -1,7 +1,9 @@
-Not very much to do:
+# $Id$
+
+For installing URM there is fot very much to do:
Try
make test
-to see if your perl is capable of running urmc
+to see if your perl is capable of running urmc.
Then try to build the examples:
make examples
You'll end up with a bunch of pasm files in the
Modified: trunk/languages/urm/README
==============================================================================
--- trunk/languages/urm/README (original)
+++ trunk/languages/urm/README Thu May 5 07:06:34 2005
@@ -1,3 +1,5 @@
+# $Id$
+
urmc - an URM compiler for Parrot
2003 (c) by Marcus Thiesen <[EMAIL PROTECTED]>
Added: trunk/languages/urm/lib/URM/Test.pm
==============================================================================
--- (empty file)
+++ trunk/languages/urm/lib/URM/Test.pm Thu May 5 07:06:34 2005
@@ -0,0 +1,91 @@
+# $Id$
+
+package URM::Test;
+
+use strict;
+use vars qw(@EXPORT @ISA);
+
+use Parrot::Config;
+
+require Exporter;
+require Parrot::Test;
+
[EMAIL PROTECTED] = ( qw(output_is output_like output_isnt),
@Test::More::EXPORT );
[EMAIL PROTECTED] = qw(Exporter Test::More);
+
+sub import {
+ my( $class, $plan, @args ) = @_;
+
+ Test::More->import( $plan, @args );
+
+ __PACKAGE__->_export_to_level( 2, __PACKAGE__ );
+}
+
+my $count;
+
+foreach my $meth ( qw(is isnt like) ) {
+ no strict 'refs';
+
+ *{"URM::Test::output_$meth"} = sub {
+ my( $lang_code, $output, $desc, @other ) = @_;
+
+ ++$count;
+ my( $lang_f, $pasm_f, $by_f, $out_f ) = map { # JMG
+ my $t = $0; $t =~ s/\.t$/_$count\.$_/; $t
+ } ( qw(urm pasm pbc out) ); # JMG
+
+ # STDERR is written into same output file
+ open LANG, "> $lang_f" or die "Unable to open '$lang_f'"; # JMG
+ binmode LANG; # JMG
+ print LANG $lang_code; # JMG
+ close LANG; # JMG
+
+ Parrot::Test::run_command(
+ "$PConfig{perl} languages/urm/urmc -s languages/$lang_f",
+ CD => '..', # $self->{relpath},
+ STDOUT => $pasm_f, STDERR => $pasm_f,
+ );
+ Parrot::Test::run_command(
+ "./parrot languages/$pasm_f @other",
+ CD => '..', # $self->{relpath},
+ STDOUT => $out_f, STDERR => $out_f,
+ );
+ my $prog_output = Parrot::Test::slurp_file( "$out_f" );
+
+ @_ = ( $prog_output, $output, $desc );
+ #goto &{"Test::More::$meth"};
+ my $ok = &{"Test::More::$meth"}( @_ );
+ # if( $ok ) { foreach my $meth ( $lang_f, $pasm_f, $by_f, $out_f ) {
unlink $meth } } # JMG
+ }
+}
+
+1;
+
+my $urmc = "$PConfig{perl}
$FindBin::RealBin$PConfig{slash}..$PConfig{slash}urmc";
+my $compile = "-c -s";
+my $run = "-s";
+
+sub compile_test {
+ my $file = shift;
+
+ my $ret = system ("$urmc $compile $FindBin::RealBin$PConfig{slash}$file");
+ if ($ret) {
+ print STDERR "TEST FAILED: $file ($ret)\n";
+ return;
+ }
+ print "OK: $file\n";
+}
+
+sub run_test {
+ my ($file, $expect) = @_;
+ my $ret = `$urmc $run $FindBin::RealBin$PConfig{slash}$file`;
+ if (!$ret) {
+ print STDERR "TEST FAILED: $file didn't return a value, Parrot
crashed?\n";
+ return;
+ }
+ if ($ret != $expect) {
+ print STDERR "TEST FAILED: $file (got $ret expected $expect)\n";
+ return;
+ }
+ print "OK: $file\n";
+}
Copied: trunk/languages/urm/t/harness (from rev 7981,
trunk/languages/urm/t/t.pl)
==============================================================================
--- trunk/languages/urm/t/t.pl (original)
+++ trunk/languages/urm/t/harness Thu May 5 07:06:34 2005
@@ -1,41 +1,59 @@
-#! perl -w
+# $Id$
+
+=head1 NAME
+
+languages/urm/t/harness - A harness for urm
+
+=head1 SYNOPSIS
+
+ cd languages && perl -I../lib urm/t/harness ---files
+
+ cd languages && perl -I../lib urm/t/harness
+
+ cd languages && perl -I../lib urm/t/harness urm/t/testmmu.t urm/t/testmmu2.t
+
+=head1 DESCRIPTION
+
+If I'm called with a single argument of "--files",
+ I just return a list of files to process.
+This list is one per line, and is relative to the languages dir.
+
+If I'm called with no args, I run the complete suite.
+
+Otherwise I run the tests that were passed on the command line.
+
+=cut
use strict;
use FindBin;
use lib '../../lib';
use Parrot::Config;
+use Test::Harness();
-my $urmc = "$PConfig{perl}
$FindBin::RealBin$PConfig{slash}..$PConfig{slash}urmc";
-my $compile = "-c -s";
-my $run = "-s";
-
-sub compile_test {
- my $file = shift;
-
- my $ret = system ("$urmc $compile $FindBin::RealBin$PConfig{slash}$file");
- if ($ret) {
- print STDERR "TEST FAILED: $file ($ret)\n";
- return;
- }
- print "OK: $file\n";
-}
+my $language = 'urm';
-sub run_test {
- my ($file, $expect) = @_;
- my $ret = `$urmc $run $FindBin::RealBin$PConfig{slash}$file`;
- if (!$ret) {
- print STDERR "TEST FAILED: $file didn't return a value, Parrot
crashed?\n";
- return;
- }
- if ($ret != $expect) {
- print STDERR "TEST FAILED: $file (got $ret expected $expect)\n";
- return;
- }
- print "OK: $file\n";
+if ( grep { m/^--files$/ } @ARGV ) {
+ # Only the Makefile in 'parrot/languages' uses --files
+ my $dir = File::Spec->catfile( $language, 't' );
+ my @files = glob( File::Spec->catfile( $dir, '*.t' ) );
+ print join( "\n", @files );
+ print "\n" if scalar(@files);
+} else {
+ my @files;
+ if ( scalar(@ARGV) ) {
+ # Someone specified tests for me to run.
+ @files = grep { -f $_ } @ARGV
+ }
+ else
+ {
+ ( undef, undef, my $current_dir ) = File::Spec->splitpath( Cwd::getcwd()
);
+ if ( $current_dir eq 'languages' ) {
+ @files = glob( File::Spec->catfile( $language, 't', '*.t' ) );
+ }
+ elsif ( $current_dir eq $language ) {
+ @files = glob( File::Spec->catfile( 't', '*.t' ) );
+ }
+ }
+ Test::Harness::runtests( @files ) if scalar( @files );
}
-
-compile_test("testpars.urm");
-run_test("testmmu.urm", 100);
-run_test("testmmu2.urm", 2);
-run_test("testmmu3.urm", 92);
Added: trunk/languages/urm/t/in_out.t
==============================================================================
--- (empty file)
+++ trunk/languages/urm/t/in_out.t Thu May 5 07:06:34 2005
@@ -0,0 +1,26 @@
+# $Id$
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use URM::Test tests => 3;
+
+output_is(<< 'CODE', << 'OUT', 'echo single arg', 42);
+in(r17); out(r17);
+CODE
+42
+OUT
+
+output_is(<< 'CODE', << 'OUT', 'echo 0', 0);
+in(r17); out(r17);
+CODE
+0
+OUT
+
+# URM seems to have only a single output register
+output_is(<< 'CODE', << 'OUT', 'echo 6 args ', 00, 11, 22, 33, 44, 55);
+in(r17,r18,r19,r20,r21,r22);
+out(r22);
+CODE
+55
+OUT
Copied: trunk/languages/urm/t/mmu.t (from rev 7981,
trunk/languages/urm/t/testmmu.urm)
==============================================================================
--- trunk/languages/urm/t/testmmu.urm (original)
+++ trunk/languages/urm/t/mmu.t Thu May 5 07:06:34 2005
@@ -1,5 +1,14 @@
+# $Id$
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use URM::Test tests => 3;
+
## Ok, writing my own mmu
+output_is(<< 'CODE', << 'OUT', 'from testmmu.urm');
+
out(r100);
5: r5 <- 5
@@ -198,3 +207,75 @@
198: r198 <- 198
199: r199 <- 199
200: r200 <- 200
+CODE
+100
+OUT
+
+
+
+output_is(<< 'CODE', << 'OUT', 'from testmmu.urm');
+## Ok, testing my own mmu
+## The thing leo got me with
+
+out(r32);
+
+1: r40 <- r100 + r200
+2: r32 <- 5 # should be I0
+3: r64 <- 3 # this too
+4: r128 <- 29 # and this too
+5: r32 <- r64 - 1
+CODE
+2
+OUT
+
+
+output_is(<< 'CODE', << 'OUT', 'from testmmu.urm');
+
+out(r5);
+
+5: r5 <- 5
+6: r6 <- 6
+7: r7 <- 7
+8: r8 <- 8
+9: r9 <- 9
+10: r10 <- 10
+11: r11 <- 11
+12: r12 <- 12
+13: r13 <- 13
+14: r14 <- 14
+15: r15 <- 15
+16: r16 <- 16
+17: r17 <- 17
+18: r18 <- 18
+19: r19 <- 19
+20: r20 <- 20
+21: r21 <- 21
+22: r22 <- 22
+23: r23 <- 23
+24: r24 <- 24
+25: r25 <- 25
+26: r26 <- 26
+27: r27 <- 27
+28: r28 <- 28
+29: r29 <- 29
+30: r30 <- 30
+31: r31 <- 31
+32: r32 <- 32
+33: r33 <- 33
+34: r34 <- 34
+35: r35 <- 35
+36: r36 <- 36
+37: r37 <- 37
+38: r38 <- 38
+39: r39 <- 39
+40: r40 <- 40
+41: r41 <- 41
+42: r42 <- 42
+43: r43 <- 43
+
+44: r5 <- r10 + r32
+55: r6 <- r20 + r30
+56: r5 <- r5 + r6
+CODE
+92
+OUT
Copied: trunk/languages/urm/t/syn.t (from rev 7981,
trunk/languages/urm/t/testpars.urm)
==============================================================================
--- trunk/languages/urm/t/testpars.urm (original)
+++ trunk/languages/urm/t/syn.t Thu May 5 07:06:34 2005
@@ -1,3 +1,13 @@
+# $Id$
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use URM::Test tests => 1;
+
+# Test parsing of URM code
+
+output_is(<< 'CODE', << 'OUT', 'from testpars.urm', 42, 43);
# 2003 (c) by Marcus Thiesen
# <[EMAIL PROTECTED]>
# This program is under GPL
@@ -5,7 +15,7 @@
# Testing the URM Parser
#This should work
-in(r1,r2); out(r3);
+in(r3,r2); out(r3);
#Well formated
1: r1 <- r1 + 1
@@ -29,190 +39,6 @@
11: r11 <- 0
12: r12 <- 0
13: r13 <- 0
-14: r14 <- 0
-15: r15 <- 0
-16: r16 <- 0
-17: r17 <- 0
-18: r18 <- 0
-19: r19 <- 0
-20: r20 <- 0
-21: r21 <- 0
-22: r22 <- 0
-23: r23 <- 0
-24: r24 <- 0
-25: r25 <- 0
-26: r26 <- 0
-27: r27 <- 0
-28: r28 <- 0
-29: r29 <- 0
-30: r30 <- 0
-31: r31 <- 0
-32: r32 <- 0
-33: r33 <- 0
-34: r34 <- 0
-35: r35 <- 0
-36: r36 <- 0
-37: r37 <- 0
-38: r38 <- 0
-39: r39 <- 0
-40: r40 <- 0
-41: r41 <- 0
-42: r42 <- 0
-43: r43 <- 0
-44: r44 <- 0
-45: r45 <- 0
-46: r46 <- 0
-47: r47 <- 0
-48: r48 <- 0
-49: r49 <- 0
-50: r50 <- 0
-51: r51 <- 0
-52: r52 <- 0
-53: r53 <- 0
-54: r54 <- 0
-55: r55 <- 0
-56: r56 <- 0
-57: r57 <- 0
-58: r58 <- 0
-59: r59 <- 0
-60: r60 <- 0
-61: r61 <- 0
-62: r62 <- 0
-63: r63 <- 0
-64: r64 <- 0
-65: r65 <- 0
-66: r66 <- 0
-67: r67 <- 0
-68: r68 <- 0
-69: r69 <- 0
-70: r70 <- 0
-71: r71 <- 0
-72: r72 <- 0
-73: r73 <- 0
-74: r74 <- 0
-75: r75 <- 0
-76: r76 <- 0
-77: r77 <- 0
-78: r78 <- 0
-79: r79 <- 0
-80: r80 <- 0
-81: r81 <- 0
-82: r82 <- 0
-83: r83 <- 0
-84: r84 <- 0
-85: r85 <- 0
-86: r86 <- 0
-87: r87 <- 0
-88: r88 <- 0
-89: r89 <- 0
-90: r90 <- 0
-91: r91 <- 0
-92: r92 <- 0
-93: r93 <- 0
-94: r94 <- 0
-95: r95 <- 0
-96: r96 <- 0
-97: r97 <- 0
-98: r98 <- 0
-99: r99 <- 0
-100: r100 <- 0
-101: r101 <- 0
-102: r102 <- 0
-103: r103 <- 0
-104: r104 <- 0
-105: r105 <- 0
-106: r106 <- 0
-107: r107 <- 0
-108: r108 <- 0
-109: r109 <- 0
-110: r110 <- 0
-111: r111 <- 0
-112: r112 <- 0
-113: r113 <- 0
-114: r114 <- 0
-115: r115 <- 0
-116: r116 <- 0
-117: r117 <- 0
-118: r118 <- 0
-119: r119 <- 0
-120: r120 <- 0
-121: r121 <- 0
-122: r122 <- 0
-123: r123 <- 0
-124: r124 <- 0
-125: r125 <- 0
-126: r126 <- 0
-127: r127 <- 0
-128: r128 <- 0
-129: r129 <- 0
-130: r130 <- 0
-131: r131 <- 0
-132: r132 <- 0
-133: r133 <- 0
-134: r134 <- 0
-135: r135 <- 0
-136: r136 <- 0
-137: r137 <- 0
-138: r138 <- 0
-139: r139 <- 0
-140: r140 <- 0
-141: r141 <- 0
-142: r142 <- 0
-143: r143 <- 0
-144: r144 <- 0
-145: r145 <- 0
-146: r146 <- 0
-147: r147 <- 0
-148: r148 <- 0
-149: r149 <- 0
-150: r150 <- 0
-151: r151 <- 0
-152: r152 <- 0
-153: r153 <- 0
-154: r154 <- 0
-155: r155 <- 0
-156: r156 <- 0
-157: r157 <- 0
-158: r158 <- 0
-159: r159 <- 0
-160: r160 <- 0
-161: r161 <- 0
-162: r162 <- 0
-163: r163 <- 0
-164: r164 <- 0
-165: r165 <- 0
-166: r166 <- 0
-167: r167 <- 0
-168: r168 <- 0
-169: r169 <- 0
-170: r170 <- 0
-171: r171 <- 0
-172: r172 <- 0
-173: r173 <- 0
-174: r174 <- 0
-175: r175 <- 0
-176: r176 <- 0
-177: r177 <- 0
-178: r178 <- 0
-179: r179 <- 0
-180: r180 <- 0
-181: r181 <- 0
-182: r182 <- 0
-183: r183 <- 0
-184: r184 <- 0
-185: r185 <- 0
-186: r186 <- 0
-187: r187 <- 0
-188: r188 <- 0
-189: r189 <- 0
-190: r190 <- 0
-191: r191 <- 0
-192: r192 <- 0
-193: r193 <- 0
-194: r194 <- 0
-195: r195 <- 0
-196: r196 <- 0
-197: r197 <- 0
-198: r198 <- 0
-199: r199 <- 0
-200: r200 <- 0
+CODE
+42
+OUT
Modified: trunk/languages/urm/urmc
==============================================================================
--- trunk/languages/urm/urmc (original)
+++ trunk/languages/urm/urmc Thu May 5 07:06:34 2005
@@ -1,60 +1,69 @@
#! perl -w
-# This is just another little language for Parrot
-# urmc - 2003 (c) by Marcus Thiesen
-# <[EMAIL PROTECTED]>
-# This code is under the GPL
+# urmc - 2003-2005 (c) by Marcus Thiesen
+# $Id$
-## See if we can do pasm:
+=head1 NAME
-use strict;
+urmc - This is just another little language for Parrot
-use Getopt::Long;
+=head1 LICENSE
+
+This code is under the GPL
+
+=head1 AUTHOR
+
+Markus Thiessen - <[EMAIL PROTECTED]>
+
+=cut
+
+use strict;
use FindBin;
use lib "$FindBin::RealBin/../../lib";
-use Parrot::Config;
-BEGIN { eval " use Time::HiRes qw(time); " }
-use vars qw($filename
- $compile
- $opti
- $silent);
+use Data::Dumper;
+use Getopt::Long;
+use Parrot::Config;
+# $opti is localized later
+use vars qw( $opti );
$opti = 1; # more a debug flag
+# globals
+my ( $filename, $silent );
my $parrot =
"$FindBin::RealBin$PConfig{slash}..$PConfig{slash}..$PConfig{slash}parrot$PConfig{exe}";
sub filename {
my $arg = shift;
if (-e $arg) {
- $filename = $arg;
+ $filename = $arg;
}
}
-GetOptions("compile" => \$compile,
- "silent" => \$silent,
- "<>" => \&filename
- );
+GetOptions( "silent" => \$silent,
+ "<>" => \&filename
+ );
-my $version = "0.3";
+my $version = '0.4';
my @pasm =
- ("## Compiled by urmc $version\n",
- "## 2003 (c) by Marcus Thiesen\n",
- "## <[EMAIL PROTECTED]> \n\n",
- "_MAIN:\n",
- "\tgetstdin P0 #filehandle to STDIN\n",
+ ("## Compiled by urmc $version",
+ '## 2003 (c) by Marcus Thiesen',
+ '## <[EMAIL PROTECTED]>',
+ '',
+ '_MAIN:',
+ "\tshift S1, P5 # we don't need the scriptname",
);
my $lp = qr/\s*(\d+)\s*\:/; #line prefix (1:)
my (%lines, %jtarget); # tcount lines and jump targets
-my $out; # save the output registers name
+my $out_reg; # save the output registers name
my @source;
if ($filename) {
- open SOURCE, $filename or die "Can't get sourcefile $filename :$!\n";
+ open SOURCE, $filename or die "Can't get sourcefile $filename :$!";
@source = <SOURCE>;
close SOURCE; ### if gnu would hear that... :-)
} else {
- die "$0 <file>\n"
+ die "$0 <file>"
}
sub warning{
@@ -85,64 +94,64 @@
print "lra_tbl:\n";
}
-sub mmu{
+sub mmu {
my $name = shift;
## lookup the register
if ((defined $look_tbl{$name}) &&
- ($look_tbl{$name} =~ /^I(\d+)/)) {
- return $1;
+ ($look_tbl{$name} =~ /^I(\d+)/)) {
+ return $1;
}
## if not on stack: get a free one
foreach my $reg (sort {$a <=> $b} keys %reg_tbl) {
- unless ($reg_tbl{$reg}) {
- $reg_tbl{$reg} = $name;
- my $time = time();
- $lra_tbl{$time} = $reg;
- $look_tbl{$name} = "I$reg";
- return $reg;
- }
+ unless ($reg_tbl{$reg}) {
+ $reg_tbl{$reg} = $name;
+ my $time = time();
+ $lra_tbl{$time} = $reg;
+ $look_tbl{$name} = "I$reg";
+ return $reg;
+ }
}
### no free registers left or on stack
# on stack
if (defined $look_tbl{$name}) {
- # get last recently allocated:
- my @times = sort { $a <=> $b } keys %lra_tbl;
- my $time = shift @times;
-
- my $old = $lra_tbl{"$time"};
- die "\$old undefined\n" unless defined $old;
- delete $lra_tbl{$time};
- # save register nr $old on stack
- push @pasm, "\tsave I$old\n";
- $look_tbl{$reg_tbl{$old}} = $stackcount;
- $reg_tbl{$old} = 0;
- $stackcount++;
-
-
- # get requested register from stack
- $stackcount--;
- my $nr_on_stack = ($stackcount - $look_tbl{$name}) - 1;
- my $rotate_more = $stackcount - 1 - $nr_on_stack - 1;
-
- for my $i (0..$nr_on_stack) {
- push @pasm, "\trotate_up $stackcount\n";
- }
- push @pasm, "\trestore I$old\n";
- for my $i (0..$rotate_more) {
- push @pasm, "\trotate_up $stackcount\n";
- }
-
-
-# push @pasm, "\tlookback I$old, $nr_on_stack\n";
-
- $look_tbl{$name} = "I$old";
- $lra_tbl{time()} = $old;
- $reg_tbl{$old} = "$name";
+ # get last recently allocated:
+ my @times = sort { $a <=> $b } keys %lra_tbl;
+ my $time = shift @times;
+
+ my $old = $lra_tbl{"$time"};
+ die "\$old undefined\n" unless defined $old;
+ delete $lra_tbl{$time};
+ # save register nr $old on stack
+ push @pasm, "\tsave I$old";
+ $look_tbl{$reg_tbl{$old}} = $stackcount;
+ $reg_tbl{$old} = 0;
+ $stackcount++;
+
+
+ # get requested register from stack
+ $stackcount--;
+ my $nr_on_stack = ($stackcount - $look_tbl{$name}) - 1;
+ my $rotate_more = $stackcount - 1 - $nr_on_stack - 1;
+
+ for my $i (0..$nr_on_stack) {
+ push @pasm, "\trotate_up $stackcount";
+ }
+ push @pasm, "\trestore I$old";
+ for my $i (0..$rotate_more) {
+ push @pasm, "\trotate_up $stackcount";
+ }
- return $old;
+
+# push @pasm, "\tlookback I$old, $nr_on_stack";
+
+ $look_tbl{$name} = "I$old";
+ $lra_tbl{time()} = $old;
+ $reg_tbl{$old} = "$name";
+
+ return $old;
}
# no free register left
@@ -153,7 +162,7 @@
my $old = $lra_tbl{"$time"};
delete $lra_tbl{$time};
# save register nr $old on stack
- push @pasm, "\tsave I$old\n";
+ push @pasm, "\tsave I$old";
$look_tbl{$reg_tbl{$old}} = $stackcount;
$reg_tbl{$old} = 0;
$stackcount++;
@@ -163,90 +172,91 @@
### The parser
foreach my $line (@source) {
next unless defined $line;
- next if $line =~ /^\#/; #comments and spacy lines
- next if $line =~ /^\s+$/;
- $line =~ s/\#.+//; # stip in line comments;
+ next if $line =~ /^\#/; # comments
+ next if $line =~ /^\s+$/; # spacy lines
+ $line =~ s/\#.+//; # stip in line comments;
chomp $line;
- #parse in(r1,r2,...)
- if ($line =~ /\s*in\(/) {
- while ($line =~ /(r(\d+))/g) {
- my $rn = "I" . (mmu $2);
- push @pasm, "\t#get input for $1\n";
- push @pasm, "\tprint \"$1: \"\n";
- push @pasm, "\treadline S0, P0\n";
- push @pasm, "\tset $rn, S0\n";
- }
- next;
- }
- #parse out(r3)
- elsif ($line =~ /\s*out\(r(\d+)\)/) {
- $out = $1;
- next;
+ # parse in(r1,r2); out(r3); or out(r3); or in(r34);
+ if ( ( undef, my $in, undef, my $out ) =
+ $line =~ m/^(\s*in\(([0-9r\ ,]*?)\);)? # optional input registers
+ (\s*out\(r(\d+)\);)? # optional output
register
+ \s*$ # insignificant lines are
already skipped
+ /x ) {
+ $in ||= '';
+ $out_reg = $out if defined $out;
+ foreach ( split( /\s*,\s*/, $in ) ) {
+ my ( $in_reg ) = m/r(\d+)/;
+ my $rn = "I" . (mmu $in_reg);
+ push @pasm, "\t#get input for $_";
+ push @pasm, "\tshift S0, P5";
+ push @pasm, "\tset $rn, S0";
+ }
+ next;
}
#parse 0: r3 <- 0
elsif ($line =~ /$lp\s*r(\d+)\s*<-\s*(\d+)\s*$/o) {
- $lines{$1} = 1;
- if ($3 != 0) {
- local $opti = 0;
- warning("Assigning not 0 to a register", $1);
- }
- ## parrot does the work for us....
- if ($opti <= 1) {
- push @pasm, "L$1:\n";
- push @pasm, "\tset I" . (mmu($2)) . ", $3\t\#$line\n";
- next;
+ $lines{$1} = 1;
+ if ($3 != 0) {
+ local $opti = 0;
+ warning("Assigning not 0 to a register", $1);
+ }
+ ## parrot does the work for us....
+ if ($opti <= 1) {
+ push @pasm, "L$1:";
+ push @pasm, "\tset I" . (mmu($2)) . ", $3\t\#$line";
+ next;
}
}
#parse 3: if r2 = 0 goto 7
elsif ($line =~ /$lp\s*if\sr(\d+)\s*=\s*0\s*goto\s*(\d+)/o) {
- $lines{$1} = 1;
- push @pasm, "L$1:\n";
- push @pasm, "\teq I" . (mmu $2) . ", 0, L$3\t\#$line\n";
- $jtarget{$3} = 1;
- next;
+ $lines{$1} = 1;
+ push @pasm, "L$1:";
+ push @pasm, "\teq I" . (mmu $2) . ", 0, L$3\t\#$line";
+ $jtarget{$3} = 1;
+ next;
}
elsif ($line =~ /^inline_pasm:/) {
- $line =~ s/^inline_pasm://;
- push @pasm, $line . "\n";
- next;
+ $line =~ s/^inline_pasm://;
+ push @pasm, $line;
+ next;
}
#parse 4: r2 <- r2 +|- 1
elsif ($line =~
- /$lp\s*r(\d+)\s*<-\s*r(\d+)\s*(\+|-)\s*(?:(r(\d+))|(\d+))/o ) {
- $lines{$1} = 1;
- if ($2 != $3) {
- warning("Assigning one register to another", $1);
- }
- my $rn3;
- if (defined $6) {
- warning("Assigning sum of two registers", $1);
- $rn3 = "I" . (mmu $6);
- }
- elsif ((defined $6) && ($6 != 1)) {
- warning("Adding more than one", $1);
- }
-
- push @pasm, "L$1:\n";
- my $rn1 = "I" . (mmu $2);
- my $rn2 = "I" . (mmu $3);
- $rn3 = 1 unless defined $rn3;
- if ($4 eq "+") {
- push @pasm, "\tadd $rn1, $rn2, $rn3\t\#$line\n";
- } else {
- push @pasm, "\tsub $rn1, $rn2, $rn3\t\#$line\n";
- }
- next;
+ /$lp\s*r(\d+)\s*<-\s*r(\d+)\s*(\+|-)\s*(?:(r(\d+))|(\d+))/o ) {
+ $lines{$1} = 1;
+ if ($2 != $3) {
+ warning("Assigning one register to another", $1);
+ }
+ my $rn3;
+ if (defined $6) {
+ warning("Assigning sum of two registers", $1);
+ $rn3 = "I" . (mmu $6);
+ }
+ elsif ((defined $6) && ($6 != 1)) {
+ warning("Adding more than one", $1);
+ }
+
+ push @pasm, "L$1:";
+ my $rn1 = "I" . (mmu $2);
+ my $rn2 = "I" . (mmu $3);
+ $rn3 = 1 unless defined $rn3;
+ if ($4 eq "+") {
+ push @pasm, "\tadd $rn1, $rn2, $rn3\t\#$line";
+ } else {
+ push @pasm, "\tsub $rn1, $rn2, $rn3\t\#$line";
+ }
+ next;
}
#parse 5: goto 5
elsif ($line =~ /$lp\s*goto\s*(\d+)/) {
- $lines{$1} = 1;
- push @pasm, "L$1:\n";
- push @pasm, "\tbranch L$2\t\#$line\n";
- $jtarget{$2} = 1;
- next;
+ $lines{$1} = 1;
+ push @pasm, "L$1:";
+ push @pasm, "\tbranch L$2\t\#$line";
+ $jtarget{$2} = 1;
+ next;
}
else {
- die "SYNTAX ERROR:\n$line\nCan't parse line\n";
+ die "SYNTAX ERROR:\n$line\nCan't parse line\n";
}
}
@@ -256,47 +266,34 @@
## clean up the labels
if ($opti > 0) {
for my $line (@pasm) {
- if ($line =~ /^L(\d+)/) {
- push @newpasm, $line if exists $jtarget{$1};
- next;
- }
- push @newpasm, $line;
+ if ($line =~ /^L(\d+)/) {
+ push @newpasm, $line if exists $jtarget{$1};
+ next;
+ }
+ push @newpasm, $line;
}
@pasm = @newpasm;
}
if (scalar %jtarget) {
foreach my $key (keys %jtarget) {
- next if exists $lines{$key};
- if (defined $out) {
- $out = mmu($out);
- push @pasm, "L$key:\n";
- push @pasm, "\tprint I$out\n";
- push @pasm, "\tprint \"\\n\"\n";
- }
- push @pasm, "\tend\n";
+ next if exists $lines{$key};
+ if (defined $out_reg) {
+ $out_reg = mmu($out_reg);
+ push @pasm, "L$key:";
+ push @pasm, "\tprint I$out_reg";
+ push @pasm, "\tprint \"\\n\"";
+ }
+ push @pasm, "\tend";
}
} else {
- if (defined $out) {
- $out = mmu($out);
- push @pasm, "\tprint I$out\n";
- push @pasm, "\tprint \"\\n\"\n";
- push @pasm, "end\n";
+ if (defined $out_reg) {
+ $out_reg = mmu($out_reg);
+ push @pasm, "\tprint I$out_reg";
+ push @pasm, "\tprint \"\\n\"";
}
+ push @pasm, "end";
}
-if ($compile) {
- $filename =~ s/\.urm/.pasm/;
- open OUT, ">$filename";
- print OUT @pasm;
- close OUT;
- } else {
- $filename = ".$$." . time() . ".pasm" ;
- open OUT, ">$filename";
- print OUT @pasm;
- close OUT;
- system ("$parrot $filename");
- unlink $filename;
-}
-
-
+# Consider this as a treewalker of an degenerate tree
+print join("\n", @pasm), "\n";
