All --
I want to commit some bug fixes and new features for Jako. Given the
freeze, though, I want to make sure that if I do it, nobody is
depending upon jakoc as anything other than an illustration for now.
It works great here (much better than the current CVS version), and
will probably work great for you.
But, given that there are more than just fixes, I want to give folks
a chance to say "hold up" before I push the Big Red Button.
Here's what you'll find:
* Added a primes.jako based on the primes.pasm example from the list.
* Source code printed in assembler comments.
* const int n = 5
* while ( ... ) { ... } continue { ... }
* Fixed const-reg and reg-const handling code in comparisons
* Fixed num-int and int-num arg promotion
* Some fixed ops.
In case anyone really wants to stare at the patch before forming an
opinion, I'm attaching it. I'm also attaching the primes.jako
source and the primes.pasm assembler file. Note that you'll also
need the one-line assemble.pl patch (which allows end-of-line
comments).
Regards,
-- Gregor
_____________________________________________________________________
/ perl -e 'srand(-2091643526); print chr rand 90 for (0..4)' \
Gregor N. Purdy [EMAIL PROTECTED]
Focus Research, Inc. http://www.focusresearch.com/
8080 Beckett Center Drive #203 513-860-3570 vox
West Chester, OH 45069 513-860-3579 fax
\_____________________________________________________________________/
Index: assemble.pl
===================================================================
RCS file: /home/perlcvs/parrot/assemble.pl,v
retrieving revision 1.34
diff -u -r1.34 assemble.pl
--- assemble.pl 2001/09/21 05:06:23 1.34
+++ assemble.pl 2001/09/21 13:45:14
@@ -188,6 +188,7 @@
1 while $code=~s/\"([^\\\"]*(?:\\.[^\\\"]*)*)\"/constantize($1)/eg;
$code=~s/,/ /g;
+ $code =~ s/#.*$//; # Strip end-of-line comments
my($opcode,@args)=split(/\s+/,$code);
if(exists($macros{$opcode})) {
# found a macro
? primes.jako
? jako.patch
Index: Makefile
===================================================================
RCS file: /home/perlcvs/parrot/little_languages/Makefile,v
retrieving revision 1.5
diff -u -r1.5 Makefile
--- Makefile 2001/09/17 12:51:47 1.5
+++ Makefile 2001/09/21 13:45:47
@@ -34,7 +34,10 @@
hello.pasm: hello.jako jakoc
jakoc hello.jako > hello.pasm
+primes.pasm: primes.jako jakoc
+ jakoc primes.jako > primes.pasm
+
#
# Assembly:
#
@@ -54,15 +57,18 @@
hello.pbc: hello.pasm ../assemble.pl
cd ..; assemble.pl $(DIR)/hello.pasm > $(DIR)/hello.pbc
+primes.pbc: primes.pasm ../assemble.pl
+ cd ..; assemble.pl $(DIR)/primes.pasm > $(DIR)/primes.pbc
+
#
# Other targets:
#
-all: bench.pbc euclid.pbc fact.pbc fib.pbc hello.pbc
+all: bench.pbc euclid.pbc fact.pbc fib.pbc hello.pbc primes.pbc
clean:
- rm -f bench.pasm euclid.pasm euclid.pbc fact.pasm fact.pbc fib.pasm fib.pbc
hello.pasm hello.pbc
+ rm -f bench.pasm euclid.pasm euclid.pbc fact.pasm fact.pbc fib.pasm fib.pbc
+hello.pasm hello.pbc primes.pasm primes.pbc
over:
@make clean
@@ -74,6 +80,7 @@
cd ..; test_prog $(DIR)/fact.pbc
cd ..; test_prog $(DIR)/fib.pbc
cd ..; test_prog $(DIR)/hello.pbc
+ cd ..; test_prog $(DIR)/primes.pbc
#
# End of file.
Index: bench.jako
===================================================================
RCS file: /home/perlcvs/parrot/little_languages/bench.jako,v
retrieving revision 1.2
diff -u -r1.2 bench.jako
--- bench.jako 2001/09/17 12:51:27 1.2
+++ bench.jako 2001/09/21 13:45:47
@@ -23,10 +23,10 @@
# $Id: bench.jako,v 1.2 2001/09/17 12:51:27 gregor Exp $
#
-var int q = 1;
-var int w = 1;
-var int i = 1;
-var int j = 1;
+var int q = 1;
+var int w = 1;
+var int i = 1;
+var int j = 1;
while (q < 100) {
w = 1;
@@ -40,6 +40,3 @@
q++;
}
-
-end
-
Index: euclid.jako
===================================================================
RCS file: /home/perlcvs/parrot/little_languages/euclid.jako,v
retrieving revision 1.5
diff -u -r1.5 euclid.jako
--- euclid.jako 2001/09/17 12:51:27 1.5
+++ euclid.jako 2001/09/21 13:45:47
@@ -24,14 +24,11 @@
print("Algorithm E (Euclid's algorithm)\n");
print(" Calculating gcd($m, $n) = ...\n");
-r = mod(m, n);
+r = m % n;
while (r != 0) {
m = n;
n = r;
- r = mod(m, n);
+ r = m % n;
}
print(" ... = $n\n");
-
-end;
-
Index: fact.jako
===================================================================
RCS file: /home/perlcvs/parrot/little_languages/fact.jako,v
retrieving revision 1.3
diff -u -r1.3 fact.jako
--- fact.jako 2001/09/17 12:51:27 1.3
+++ fact.jako 2001/09/21 13:45:47
@@ -12,10 +12,11 @@
# $Id: fact.jako,v 1.3 2001/09/17 12:51:27 gregor Exp $
#
-var int n = 15;
-var int i = 0;
-var int f = 1;
+const int n = 15;
+var int i = 0;
+var int f = 1;
+
print("Algorithm F1 (The factorial function)\n");
print(" Calculating fact($n) = ...\n");
@@ -25,5 +26,3 @@
}
print(" ... = $f\n");
-
-end;
Index: fib.jako
===================================================================
RCS file: /home/perlcvs/parrot/little_languages/fib.jako,v
retrieving revision 1.3
diff -u -r1.3 fib.jako
--- fib.jako 2001/09/17 12:51:27 1.3
+++ fib.jako 2001/09/21 13:45:47
@@ -1,5 +1,5 @@
#
-# fibo.jako
+# fib.jako
#
# Adapted from fibo.pasm by [EMAIL PROTECTED]
#
@@ -10,12 +10,13 @@
# $Id: fib.jako,v 1.3 2001/09/17 12:51:27 gregor Exp $
#
-var int n = 24;
-var int a = 1;
-var int b = 1;
-var int f = 1;
-var int i = 3;
+const int n = 24;
+var int a = 1;
+var int b = 1;
+var int f = 1;
+var int i = 3;
+
print("Algorithm F2 (Fibonacci's function)\n");
print(" Calculating fib($n) = ...\n");
@@ -27,6 +28,3 @@
}
print(" ... = $f\n");
-
-end;
-
Index: hello.jako
===================================================================
RCS file: /home/perlcvs/parrot/little_languages/hello.jako,v
retrieving revision 1.2
diff -u -r1.2 hello.jako
--- hello.jako 2001/09/17 12:51:27 1.2
+++ hello.jako 2001/09/21 13:45:47
@@ -11,5 +11,3 @@
#
print("Hello, world!\n");
-end;
-
Index: jakoc
===================================================================
RCS file: /home/perlcvs/parrot/little_languages/jakoc,v
retrieving revision 1.8
diff -u -r1.8 jakoc
--- jakoc 2001/09/20 13:06:53 1.8
+++ jakoc 2001/09/21 13:45:48
@@ -19,13 +19,17 @@
use strict;
+use Carp;
+
#
# Global variables:
#
my $line; # Current source line number
+
my %ident; # Identifiers
+
my %regs = ( # Registers
I => [ undef ], # $regs{I}[0] reserved for integral temporaries
N => [ undef ], # $regs{N}[0] reserved for numeric temporaries
@@ -33,6 +37,13 @@
S => [ undef ], # $regs{S}[0] reserved for string temporaries
);
+my %types = (
+ 'I' => 'int',
+ 'N' => 'num',
+ 'P' => 'poly',
+ 's' => 'str',
+);
+
my $block_count = 0;
my @block_stack = ();
@@ -67,23 +78,156 @@
#
+# push_label()
+#
+# Used to push a label onto a stack of labels that will get
+# printed at the beginning of the next emit_code() call.
+#
+# Actually, pushes as many labels as there are arguments.
+#
+
+my @label_stack = ( );
+
+sub push_label
+{
+ push @label_stack, grep { defined $_ and $_ ne '' } @_;
+}
+
+
+#
+# push_comment()
+#
+# Used to push a comment onto a stack of comments that will get
+# printed at the beginning of the next emit_code() call.
+#
+# Actually, pushes as many comments as there are arguments.
+#
+
+my @comment_stack = ( );
+
+sub push_comment
+{
+ push @comment_stack, grep { defined $_ and $_ ne '' } @_;
+}
+
+
+#
+# push_source()
+#
+# Used to push source code comments. This allows them to be
+# indented.
+#
+
+sub push_source
+{
+ my $block_indent = ' ' x scalar(@block_stack);
+ push_comment map { $block_indent . $_ } @_;
+}
+
+
+#
# emit_code()
#
# emit_code LABEL
# emit_code LABEL OP
# emit_code LABEL OP ARGS
+# emit_code LABEL OP ARGS COMMENT
#
# Label can be undef.
#
+my $last_op = 'noop';
+
sub emit_code
{
- my ($label, $op, @args) = @_;
+ my ($op, $args, $comment) = @_;
+
+ #
+ # Incorporate any comments into the comment stack:
+ #
+
+ push_comment($comment) if defined $comment and $comment ne '';
+ $comment = undef;
+
+ #
+ # Complain about any undefined arguments:
+ #
+
+ if (defined $args and grep { !defined $_ } @$args) {
+ confess "jakoc: Internal error: Undefined arguments to emit_code()!";
+ return;
+ }
+
+ #
+ # Print out all but the last comment, each on a line by itself:
+ #
+ # NOTE: As of 2001-09-20, the assembler doesn't handle lines with
+ # only a label and a comment. So, we write these out separately.
+ #
+
+ $comment = pop @comment_stack if @comment_stack;
+
+ foreach my $comment (@comment_stack) {
+ printf "%-16s %-8s %-25s # %s\n", '', '', '', $comment;
+ }
+
+ @comment_stack = ( );
+
+ #
+ # Print out all but the last label, each on a line by itself:
+ #
+
+ my $label = pop @label_stack if @label_stack;
+
+ foreach my $label (@label_stack) {
+ print "$label:\n";
+ }
+
+ @label_stack = ( );
+
+ #
+ # Print out the label for the actual code line (if any):
+ #
+
+ if (defined $label and $label ne '') {
+ printf "%-16s ", "$label:";
+ } else {
+ printf "%-16s ", '';
+ }
+
+ #
+ # Print out the op mnemonic, if any:
+ #
+
+ if (defined $op) {
+ printf "%-8s", $op;
+ $last_op = $op;
+ } else {
+ printf "%-8s", '';
+ }
+
+ #
+ # Print out the arguments, if any:
+ #
+
+ if (defined $args and @$args) {
+ printf " %-25s", join(", ", @$args);
+ } else {
+ printf " %-25s", '';
+ }
- printf "%-12s ", ((defined $label and $label ne '') ? "$label:" : '');
- printf "%-8s", $op if defined $op;
- print " " if @args;
- print join(", ", @args) if @args;
+ #
+ # Print out the comment, if any:
+ #
+
+ if (defined $comment) {
+ printf(" # %s", $comment) if defined $comment;
+ }
+
+ #
+ # End the line like a good text generator:
+ #
+
print "\n";
}
@@ -95,24 +239,88 @@
sub int_q
{
my ($value) = @_;
-
return $value =~ m/^-?\d+$/;
}
#
+# num_q()
+#
+
+sub num_q
+{
+ my ($value) = @_;
+ return $value =~ m/^-?\d+\.\d+$/;
+}
+
+
+#
+# int_or_num_q()
+#
+
+sub int_or_num_q
+{
+ my ($value) = @_;
+ return $value =~ m/^-?\d+(\.\d+)?$/;
+}
+
+
+#
# reg_q()
#
sub reg_q
{
my ($value) = @_;
-
return $value =~ m/^[INPS]\d+$/;
}
#
+# int_reg_q()
+#
+
+sub int_reg_q
+{
+ my ($value) = @_;
+ return $value =~ m/^I\d+$/;
+}
+
+
+#
+# num_reg_q()
+#
+
+sub num_reg_q
+{
+ my ($value) = @_;
+ return $value =~ m/^N\d+$/;
+}
+
+
+#
+# poly_reg_q()
+#
+
+sub poly_reg_q
+{
+ my ($value) = @_;
+ return $value =~ m/^P\d+$/;
+}
+
+
+#
+# str_reg_q()
+#
+
+sub str_reg_q
+{
+ my ($value) = @_;
+ return $value =~ m/^S\d+$/;
+}
+
+
+#
# op_comp()
#
# There are three kinds of entries in the %comp_ops hash:
@@ -126,6 +334,8 @@
# we need to reverse the sense of the operator as it appears
# in the source.
#
+# TODO: Handle numeric comparisons, too!
+#
my %comp_ops = (
'eq' => sub { $_[0] == $_[1] },
@@ -152,37 +362,79 @@
sub op_comp
{
- my ($label, $op, $a, $b, $true, $false) = @_;
+ my ($type, $op, $a, $b, $true, $false) = @_;
$op = $comp_ops{$op} unless ref $comp_ops{$op}; # Map, e.g., '>=' to 'ge'
+ #
+ # OPTIMIZE const-const comparisons to unconditional branches:
+ #
+
+ if (int_or_num_q($a) and int_or_num_q($b)) {
+ if (&{$comp_ops{$op}}($a, $b)) {
+ emit_code('branch', [$true]);
+ } else {
+ emit_code('branch', [$false]);
+ }
+
+ return;
+ }
+
+ #
+ # CONVERT const-reg and reg-const comparisons to reg-reg comparisons:
+ #
+
+ if (int_q($a)) {
+ emit_code('set', [int_reg_q($b) ? 'I0' : 'N0', $a]);
+ $a = 'I0';
+ } elsif (num_q($a)) {
+ emit_code('set', ['N0', $a]);
+ $a = 'N0';
+ } elsif (!reg_q($a)) {
+ printf STDERR "jako: Syntax error on line %d!\n", $line;
+ }
+
if (int_q($b)) {
- if (int_q($a)) {
- if (&{$comp_ops{$op}}($a, $b)) {
- emit_code($label, 'branch', $true);
- } else {
- emit_code($label, 'branch', $false);
- }
- } elsif (reg_q($a)) {
- emit_code($label, 'set', 'I0', $b);
- emit_code(undef, $op, $a, 'I0', $true);
- emit_code('', 'branch', $false);
- } else {
- printf STDERR "jako: Syntax error on line %d!\n", $line;
- }
- } elsif (reg_q($b)) {
- if (int_q($a)) {
- emit_code($label, 'set', 'I0', $a);
- emit_code(undef, $op, 'I0', $b, $true);
- emit_code('', 'branch', $false);
- } elsif (reg_q($a)) {
- emit_code($label, $op, $a, $b, $true);
- emit_code('', 'branch', $false);
+ emit_code('set', [int_reg_q($a) ? 'I0' : 'N0', $b]);
+ $b = 'I0';
+ } elsif (num_q($b)) {
+ emit_code('set', ['N0', $b]);
+ $b = 'N0';
+ } elsif (!reg_q($b)) {
+ printf STDERR "jako: Syntax error on line %d!\n", $line;
+ }
+
+ #
+ # CONVERT num-int and int-num comparisons to num-num comparisons:
+ #
+
+ if (substr($a, 0, 1) ne substr($b, 0, 1)) {
+ if ($a =~ m/^I/) {
+ emit_code('iton', ['N0', $a]);
+ $a = 'N0';
+ } elsif ($b =~ m/^I/) {
+ emit_code('iton', ['N0', $b]);
+ $b = 'N0';
} else {
- printf STDERR "jako: Syntax error on line %d!\n", $line;
+ confess "jako: Internal compiler error. Expected to have to use iton op.";
+ }
+ }
+
+ #
+ # EMIT code:
+ #
+
+ if (defined $true) {
+ emit_code($op, [$a, $b, $true]);
+ if (defined $false) {
+ emit_code('branch', [$false]);
}
} else {
- printf STDERR "jako: Syntax error on line %d!\n", $line;
+ if (defined $false) {
+ op_comp($type, $comp_ops{"!$op"}, $a, $b, $false, $true);
+ } else {
+ confess "jako: Internal compiler error: op_comp called without any
+destinations!";
+ }
}
}
@@ -204,7 +456,8 @@
sub op_eq
{
my ($label, $a, $b, $le, $gt) = @_;
- op_comp($label, 'eq', $a, $b, $le, $gt);
+ push_label($label);
+ op_comp(undef, 'eq', $a, $b, $le, $gt);
}
@@ -225,7 +478,8 @@
sub op_ne
{
my ($label, $a, $b, $le, $gt) = @_;
- op_comp($label, 'ne', $a, $b, $le, $gt);
+ push_label($label);
+ op_comp(undef, 'ne', $a, $b, $le, $gt);
}
@@ -246,7 +500,8 @@
sub op_le
{
my ($label, $a, $b, $le, $gt) = @_;
- op_comp($label, 'le', $a, $b, $le, $gt);
+ push_label($label);
+ op_comp(undef, 'le', $a, $b, $le, $gt);
}
@@ -267,7 +522,8 @@
sub op_lt
{
my ($label, $a, $b, $le, $gt) = @_;
- op_comp($label, 'lt', $a, $b, $le, $gt);
+ push_label($label);
+ op_comp(undef, 'lt', $a, $b, $le, $gt);
}
@@ -288,7 +544,8 @@
sub op_ge
{
my ($label, $a, $b, $le, $gt) = @_;
- op_comp($label, 'ge', $a, $b, $le, $gt);
+ push_label($label);
+ op_comp(undef, 'ge', $a, $b, $le, $gt);
}
@@ -309,7 +566,8 @@
sub op_gt
{
my ($label, $a, $b, $le, $gt) = @_;
- op_comp($label, 'gt', $a, $b, $le, $gt);
+ push_label($label);
+ op_comp(undef, 'gt', $a, $b, $le, $gt);
}
@@ -324,21 +582,22 @@
# printf(STDERR "jako: debug: Declaring variable '%s' of type '%s'...\n", $name,
$type);
if ($ident{$name}) {
- printf STDERR "jako: Redeclaration of variable '%s' on line %d. Previous
declaration on line %d.\n",
+ printf STDERR "jako: Redeclaration of identifier '%s' on line %d. Previous
+declaration on line %d.\n",
$name, $line, $ident{$name}{LINE};
return 0;
} else {
my $num = scalar @{$regs{$type}};
- $ident{$name}{LINE} = $line;
- $ident{$name}{TYPE} = $type;
- $ident{$name}{NUM} = $num;
- $ident{$name}{REG} = "$type$num";
+ $ident{$name}{LINE} = $line;
+ $ident{$name}{TYPE} = $type;
+ $ident{$name}{NUM} = $num;
+ $ident{$name}{REG} = "$type$num";
+ $ident{$name}{VALUE} = "$type$num";
$regs{$type}[$num]{LINE} = $line;
$regs{$type}[$num]{NAME} = $name;
- print "# $name: $type$num\n";
+ push_source "var $types{$type} $name;";
return 1;
}
@@ -346,6 +605,34 @@
#
+# declare_const()
+#
+
+sub declare_const
+{
+ my ($name, $type, $value) = @_;
+
+# printf(STDERR "jako: debug: Declaring constant '%s' of type '%s'...\n", $name,
+$type);
+
+ if ($ident{$name}) {
+ printf STDERR "jako: Redeclaration of identifier '%s' on line %d. Previous
+declaration on line %d.\n",
+ $name, $line, $ident{$name}{LINE};
+ return 0;
+ } else {
+ $ident{$name}{LINE} = $line;
+ $ident{$name}{TYPE} = $type;
+ $ident{$name}{NUM} = undef;
+ $ident{$name}{REG} = undef;
+ $ident{$name}{VALUE} = $value;
+
+ push_source "const $types{$type} $name = $value;";
+
+ return 1;
+ }
+}
+
+
+#
# assign_var()
#
@@ -354,26 +641,33 @@
my ($name, $type, $value) = @_;
if ($ident{$name}) {
+ if (!defined $ident{$name}{REG}) {
+ printf(STDERR "jako: Cannot assign to constant '%s' on line %d.\n", $name,
+$line);
+ return;
+ }
+
+ push_source "$name = $value";
+
if ($type eq '*') {
if ($ident{$value}) {
if ($ident{$name}{TYPE} ne $ident{$value}{TYPE}) {
if ($ident{$name}{TYPE} eq "N" and $ident{$value}{TYPE} eq "I") {
- printf "%-12s %-8s %s\n", '', 'iton', "$ident{$name}{REG},
$ident{$value}{REG}";
+ emit_code('iton', ["$ident{$name}{REG}, $ident{$value}{REG}"]);
} elsif ($ident{$name}{TYPE} eq "I" and $ident{$value}{TYPE} eq "N") {
- printf "%-12s %-8s %s\n", '', 'ntoi', "$ident{$name}{REG},
$ident{$value}{REG}";
+ emit_code('ntoi', ["$ident{$name}{REG}, $ident{$value}{REG}"]);
} else {
printf(STDERR "jako: Cannot assign type '%s' to type '%s' on line %d.\n",
$ident{$value}{TYPE}, $ident{$name}{TYPE}, $line);
}
} else {
- printf "%-12s %-8s %s\n", '', 'set', "$ident{$name}{REG},
$ident{$value}{REG}";
+ emit_code('set', [$ident{$name}{REG}, $ident{$value}{REG}]);
}
} else {
printf(STDERR "jako: Assignment from undefined variable '%s' on line %d.\n",
$value, $line);
}
} elsif ($ident{$name}{TYPE} eq $type) {
- printf "%-12s %-8s %s\n", '', 'set', "$ident{$name}{REG}, $value";
+ emit_code('set', [$ident{$name}{REG}, $value]);
} else {
printf(STDERR "jako: Assignment of %s variable from %s value not allowed on
line %d.\n",
$ident{$name}{TYPE}, $type, $line);
@@ -395,11 +689,15 @@
my @result;
foreach my $arg (@args) {
+ die "map_args(): Undefined argument in array!\n" unless defined $arg;
+
$arg =~ s/^\s+//;
$arg =~ s/\s+$//;
if ($ident{$arg}) {
- push @result, $ident{$arg}{REG};
+ confess "jakoc: Internal compiler error: Unable to fetch value for identifier
+'$arg'!"
+ unless defined $ident{$arg}{VALUE};
+ push @result, $ident{$arg}{VALUE};
} elsif ($arg =~ m/^"/) {
push @result, $arg;
} elsif ($arg =~ m/^\d+$/) {
@@ -424,10 +722,12 @@
{
my ($name, @args) = @_;
+ push_source "$name(...);" unless $name eq 'print';
+
if ($name eq 'print') {
@args = map_args(@args);
foreach my $arg (@args) {
- printf "%-12s %-8s %s\n", '', $name, $arg;
+ emit_code($name, [$arg]);
}
} else {
printf(STDERR "jako: Unrecognized function '%s' on line %d.\n", $name, $line);
@@ -443,9 +743,11 @@
{
my ($dest, $name, @args) = @_;
+ push_source "$dest = $name(" . join(", ", @args) . ");";
+
if ($name eq 'mod') {
@args = map_args($dest, @args);
- printf "%-12s %-8s %s\n", '', $name, join(", ", @args);
+ emit_code($name, [@args]);
} else {
printf(STDERR "jako: Unrecognized function '%s' on line %d.\n", $name, $line);
}
@@ -455,34 +757,81 @@
#
# begin_block()
#
+# TODO: bare, until, unless, elsif
+#
+
+my %block_types = (
+ 'while' => { PREFIX => "_W", NEXT => 'CONT', REDO => 'REDO', LAST => 'LAST' },
+ 'if' => { PREFIX => "_I", NEXT => 'TEST', REDO => 'THEN', LAST => 'ELSE' }
+);
+my %block_names = ( );
+
sub begin_block
{
- my ($type,$cond) = @_;
- my %prefix = ( "while" => "_W", "if" => "_I" );
+ my ($name, $type, $cond) = @_;
$block_count++;
- my $prefix = "$prefix{$type}$block_count";
-
- push @block_stack, { TYPE => $type, NEXT => $line, PREFIX => $prefix };
+ my $prefix;
+
+ if (defined $name) {
+ if ($block_names{$name}) {
+ printf STDERR "jakoc: Loop named '%s' already defined at line %d (previously
+defined at line %d)!\n",
+ $name, $line, $block_names{$name};
+ }
+
+ $prefix = $name;
+ } else {
+ $prefix = "$block_types{$type}{PREFIX}$block_count";
+ $name = $prefix;
+ }
+
+ $block_names{$name} = $line;
+
+# my $next = $block_types{$type}{NEXT};
+# my $redo = $block_types{$type}{REDO};
+# my $last = $block_types{$type}{LAST};
+
+ if ($cond =~ m/^(\S+)\s*(==|!=|<=|<|>=|>)\s*(.*)$/) {
+ push_source "$name: $type ($1 $2 $3) {";
+
+ push_label "${prefix}_" . uc $type;
+
+ if ($type eq 'while') {
+ push_label "${prefix}_NEXT";
+ } elsif ($type eq 'if') {
+ push_label "${prefix}_TEST";
+ } else {
+ die;
+ }
+
+ if ($type eq 'while') {
+ op_comp($type, $2, map_args($1, $3), undef, "${prefix}_LAST");
+ } elsif ($type eq 'if') {
+ op_comp($type, $2, map_args($1, $3), undef, "${prefix}_ELSE");
+ }
- if ($cond =~ m/^(.*)\s*(==|!=|<=|<|>=|>)\s*(.*)$/) {
- op_comp("${prefix}_NEXT", $2, map_args($1, $3), "${prefix}_REDO",
"${prefix}_LAST");
- emit_code("${prefix}_REDO");
+ push_label "${prefix}_REDO";
} else {
printf(STDERR "jako: Syntax error. Unrecognized condition in '%s' on line %d.\n",
$type, $line);
}
+
+ push @block_stack, { TYPE => $type, NEXT => $line, PREFIX => $prefix };
}
#
# end_block()
#
+# TODO: else (and elsif?) blocks.
+#
sub end_block
{
+ my ($continue) = @_;
+
unless (@block_stack) {
- printf(STDERR "jako: Syntax error. Closing brace without open block on line
%d.\n", $line);
+ printf(STDERR "jakoc: Syntax error. Closing brace without open block on line
+%d.\n", $line);
return;
}
@@ -490,10 +839,29 @@
my $prefix = $block->{PREFIX};
if ($block->{TYPE} eq 'while') {
- printf("%-12s %-8s %s\n", '', 'branch', "${prefix}_NEXT", );
- }
+ if (defined $continue) {
+ if (defined $block->{CONT}) {
+ printf(STDERR "jakoc: Syntax error. No more than one continue block allowed
+on line %d.\n", $line);
+ } else {
+ $block->{CONT} = $line;
+ }
- printf "%s_LAST:\n", $prefix;
+ push_label "${prefix}_CONT";
+ push_source "} continue {";
+ push @block_stack, $block; # Push it back on for a minute...
+ } else {
+ push_source "}";
+ push_label "${prefix}_CONT" unless defined $block->{CONT};
+ emit_code('branch', ["${prefix}_NEXT"]);
+ push_label "${prefix}_LAST";
+ }
+ } elsif ($block->{TYPE} eq 'if') {
+ push_source "}";
+ emit_code();
+ push_label "${prefix}_ELSE";
+ } else {
+ confess "jakoc: Internal compiler error. End of unknown block type " .
+$block->{TYPE} . "!";
+ }
}
@@ -503,15 +871,36 @@
sub do_loop_control
{
- my $which = uc shift;
+ my ($control_op, $loop_label) = @_;
foreach (reverse @block_stack) {
- if ($_->{TYPE} eq 'while') {
- my $prefix = $_->{PREFIX};
- printf("%-12s %-8s %s\n", '', 'branch', "${prefix}_$which", );
- last;
+ my $type = $_->{TYPE};
+ my $prefix = $_->{PREFIX};
+
+ next unless $type eq 'while';
+ next unless !defined($loop_label) or $prefix eq $loop_label;
+
+ my $which = $block_types{$type}{uc $control_op};
+
+ push_source "$control_op ${prefix}";
+
+ if (defined $_->{CONT} and $control_op eq 'next') {
+ $which = $block_types{$type}{NEXT}; # Hard-coded to NEXT in
+continue { ... }
+ emit_code('branch', ["${prefix}_$which"]);
+ } else {
+ emit_code('branch', ["${prefix}_$which"]);
}
+
+ return;
}
+
+ if (defined $loop_label) {
+ printf STDERR "jakoc: No loop '%s' in loop control on line %d!\n", $loop_label,
+$line;
+ } else {
+ printf STDERR "jakoc: No loop active in loop control on line %d!\n", $line;
+ }
+
+ emit_code('err');
}
@@ -521,9 +910,31 @@
sub do_add
{
- my ($dest, $a, $b) = @_;
+ my ($dest, $a, $b) = map_args(@_);
- printf("%-12s %-8s %s\n", '', 'add', join(", ", map_args($dest, $a, $b)));
+ if (int_or_num_q($a)) {
+ if (int_or_num_q($b)) {
+ emit_code('set', [$dest, $a + $b]);
+ } elsif (reg_q($b)) {
+ my $temp = int_q($a) ? 'I0' : 'N0';
+ emit_code('set', [$temp, $a]);
+ emit_code('add', [$dest, $temp, $b]);
+ } else {
+ printf(STDERR "jakoc: Syntax error in addition on line %d!\n", $line);
+ }
+ } elsif (reg_q($a)) {
+ if (int_or_num_q($b)) {
+ my $temp = int_q($b) ? 'I0' : 'N0';
+ emit_code('set', [$temp, $b]);
+ emit_code('add', [$dest, $a, $temp]);
+ } elsif (reg_q($b)) {
+ emit_code('add', [$dest, $a, $b]);
+ } else {
+ printf(STDERR "jakoc: Syntax error in addition on line %d!\n", $line);
+ }
+ } else {
+ printf(STDERR "jakoc: Syntax error in addition on line %d!\n", $line);
+ }
}
@@ -533,7 +944,15 @@
sub do_inc
{
- printf("%-12s %-8s %s\n", '', 'inc', join(", ", map_args(@_)));
+ my ($dest, $amount) = map_args(@_);
+
+ if (defined $amount) {
+ push_source "$dest += $amount";
+ emit_code('inc', [$dest, $amount]);
+ } else {
+ push_source "$dest++";
+ emit_code('inc', [$dest]);
+ }
}
@@ -543,9 +962,31 @@
sub do_sub
{
- my ($dest, $a, $b) = @_;
+ my ($dest, $a, $b) = map_args(@_);
- printf("%-12s %-8s %s\n", '', 'sub', join(", ", map_args($dest, $a, $b)));
+ if (int_or_num_q($a)) {
+ if (int_or_num_q($b)) {
+ emit_code('set', [$dest, $a - $b]);
+ } elsif (reg_q($b)) {
+ my $temp = int_q($a) ? 'I0' : 'N0';
+ emit_code('set', [$temp, $a]);
+ emit_code('sub', [$dest, $temp, $b]);
+ } else {
+ printf(STDERR "jakoc: Syntax error in subtraction on line %d!\n", $line);
+ }
+ } elsif (reg_q($a)) {
+ if (int_or_num_q($b)) {
+ my $temp = int_q($b) ? 'I0' : 'N0';
+ emit_code('set', [$temp, $b]);
+ emit_code('sub', [$dest, $a, $temp]);
+ } elsif (reg_q($b)) {
+ emit_code('sub', [$dest, $a, $b]);
+ } else {
+ printf(STDERR "jakoc: Syntax error in subtraction on line %d!\n", $line);
+ }
+ } else {
+ printf(STDERR "jakoc: Syntax error in subtraction on line %d!\n", $line);
+ }
}
@@ -555,7 +996,15 @@
sub do_dec
{
- printf("%-12s %-8s %s\n", '', 'dec', join(", ", map_args(@_)));
+ my ($dest, $amount) = map_args(@_);
+
+ if (defined $amount) {
+ push_source "$dest -= $amount";
+ emit_code('dec', [$dest, $amount]);
+ } else {
+ push_source "$dest--";
+ emit_code('dec', [$dest]);
+ }
}
@@ -565,9 +1014,31 @@
sub do_mul
{
- my ($dest, $a, $b) = @_;
+ my ($dest, $a, $b) = map_args(@_);
- printf("%-12s %-8s %s\n", '', 'mul', join(", ", map_args($dest, $a, $b)));
+ if (int_or_num_q($a)) {
+ if (int_or_num_q($b)) {
+ emit_code('set', [$dest, $a * $b]);
+ } elsif (reg_q($b)) {
+ my $temp = int_q($a) ? 'I0' : 'N0';
+ emit_code('set', [$temp, $a]);
+ emit_code('mul', [$dest, $temp, $b]);
+ } else {
+ printf(STDERR "jakoc: Syntax error in multiplication on line %d!\n", $line);
+ }
+ } elsif (reg_q($a)) {
+ if (int_or_num_q($b)) {
+ my $temp = int_q($b) ? 'I0' : 'N0';
+ emit_code('set', [$temp, $b]);
+ emit_code('mul', [$dest, $a, $temp]);
+ } elsif (reg_q($b)) {
+ emit_code('mul', [$dest, $a, $b]);
+ } else {
+ printf(STDERR "jakoc: Syntax error in multiplication on line %d!\n", $line);
+ }
+ } else {
+ printf(STDERR "jakoc: Syntax error in multiplication on line %d!\n", $line);
+ }
}
@@ -577,9 +1048,31 @@
sub do_div
{
- my ($dest, $a, $b) = @_;
+ my ($dest, $a, $b) = map_args(@_);
- printf("%-12s %-8s %s\n", '', 'div', join(", ", map_args($dest, $a, $b)));
+ if (int_or_num_q($a)) {
+ if (int_or_num_q($b)) {
+ emit_code('set', [$dest, $a / $b]);
+ } elsif (reg_q($b)) {
+ my $temp = int_q($a) ? 'I0' : 'N0';
+ emit_code('set', [$temp, $a]);
+ emit_code('div', [$dest, $temp, $b]);
+ } else {
+ printf(STDERR "jakoc: Syntax error in division on line %d!\n", $line);
+ }
+ } elsif (reg_q($a)) {
+ if (int_or_num_q($b)) {
+ my $temp = int_q($b) ? 'I0' : 'N0';
+ emit_code('set', [$temp, $b]);
+ emit_code('div', [$dest, $a, $temp]);
+ } elsif (reg_q($b)) {
+ emit_code('div', [$dest, $a, $b]);
+ } else {
+ printf(STDERR "jakoc: Syntax error in division on line %d!\n", $line);
+ }
+ } else {
+ printf(STDERR "jakoc: Syntax error in division on line %d!\n", $line);
+ }
}
@@ -589,9 +1082,8 @@
sub do_mod
{
- my ($dest, $a, $b) = @_;
-
- printf("%-12s %-8s %s\n", '', 'mod', join(", ", map_args($dest, $a, $b)));
+ my ($dest, $a, $b) = map_args(@_);
+ emit_code('mod', [$dest, $a, $b]);
}
@@ -601,9 +1093,8 @@
sub do_shift
{
- my ($dir, $dest, $a, $amount) = @_;
-
- printf("%-12s %-8s %s\n", '', "sh$dir", join(", ", map_args($dest, $a, $amount)));
+ my ($dir, $dest, $a, $amount) = map_args(@_);
+ emit_code("sh$dir", [$dest, $a, $amount]);
}
@@ -664,20 +1155,28 @@
#
# MAIN PROGRAM:
#
+
+print
+"###############################################################################\n";
+print "# This Parrot assembler file was produced by the Jako compiler.
+#\n";
+print "# Initial comments from the source code are reproduced below.
+#\n";
+print
+"###############################################################################\n";
+print "\n";
-print "# This file produced by the Jako Compiler\n";
+my $code_lines = 0;
while(<>) {
$line++;
- if (m/^\s*#/) { print; next; } # Pass comment-only lines through intact.
- if (m/^\s*$/) { print; next; } # Pass whitespace-only lines through intact.
+ if (m/^\s*#/) { print unless $code_lines; next; } # Pass initial comment-only lines
+through intact.
+ if (m/^\s*$/) { print unless $code_lines; next; } # Pass initial whitespace-only
+lines through intact.
chomp; # Trim trailing newline
s/^\s*//; # Trim leading whitespace
s/\s*$//; # Trim trailing whitespace
last if (/^__END__$/); # Done after __END__ token
+ $code_lines++;
+
s/\s*;\s*$//; # Remove trailing semicolons
#
@@ -716,6 +1215,26 @@
}
#
+ # Constant declarations:
+ #
+ # const int foo = 5;
+ # const integer foo = 5;
+ #
+ # const num bar = 3.14;
+ # const number bar = 3.14;
+ #
+ # const str splee = "Howdy";
+ # const string splee = "Howdy";
+ #
+
+ if ((m/^const\s+(i)nt(eger)?\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(\d+))$/) ||
+ (m/^const\s+(n)um(ber)?\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(\d+(\.\d+)))$/) ||
+
+(m/^const\s+(s)tr(ing)?\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(\"[^\\\"]*(?:\\.[^\\\"]*)*\"))$/))
+ {
+ declare_const($3, uc($1), $5);
+ next;
+ }
+
+ #
# Variable Assignments:
#
# a = 5;
@@ -760,35 +1279,82 @@
next;
}
+ #
+ # Conditionals:
+ #
+ # if (...) {
+ # unless (...) {
+ #
+ # } elsif (...) {
+ #
+
+ if (m/^(if|unless)\s*\(\s*(.*)\s*\)\s*{$/) {
+ begin_block(undef, $1, $2);
+ next;
+ }
+
+ if (m/^}\s*(elsif)\s*\(\s*(.*)\s*\)\s*{$/) {
+ begin_block(undef, $1, $2);
+ # TODO
+ next;
+ }
+
#
- # Blocks:
+ # Loops:
#
- if (m/^(while|if)\s*\(\s*(.*)\s*\)\s*{$/) {
- begin_block($1,$2);
+ # LABEL: until (...) {
+ # until (...) {
+ #
+ # LABEL: while (...) {
+ # while (...) {
+ #
+
+ if (m/^(([A-Za-z][A-Za-z0-9_]*)\s*:\s*)?(until|while)\s*\(\s*(.*)\s*\)\s*{$/) {
+ begin_block($2, $3, $4);
next;
}
#
+ # Bare Blocks:
+ #
+ # LABEL: {
+ #
+ # {
+ #
+
+ if (m/^(([A-Za-z][A-Za-z0-9_]*)\s*:\s*)?{$/) {
+ begin_block($2, 'bare', undef);
+ next;
+ }
+
+ #
# Block Termination:
#
# }
+ # } continue {
+ # } else {
#
- if (m/^}$/) {
- end_block();
+ if (m/^}(\s*(continue|else)\s*{)?$/) {
+ end_block($2);
next;
}
#
# Loop Control Statements:
+ #
+ # next
+ # next LABEL
+ #
+ # last
+ # last LABEL
#
- # next;
- # last;
- # redo;
+ # redo
+ # redo LABEL
#
- if (m/^(next|last|redo)$/) {
- do_loop_control($1);
+ if (m/^(next|last|redo)(\s+([A-Za-z][A-Za-z0-9_]*))?$/) {
+ do_loop_control($1, $3);
next;
}
@@ -812,10 +1378,24 @@
# a++; # inc_[in]
#
- if
(m/([A-Za-z][A-Za-z0-9]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))\s*[+]\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/)
{
+ if
+(m/^([A-Za-z][A-Za-z0-9]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))\s*[+]\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/)
+ {
+ #
+ # Regexp Captures:
+ #
+ # 1. LHS sum (variable name)
+ # 2. RHS left addend
+ # 3. RHS left addend (variable name)
+ # 4. RHS left addend (number)
+ # 5. RHS left addend (number's decimal places) -- used for grouping, not capture
+ # 6. RHS right addend
+ # 7. RHS right addend (variable name)
+ # 8. RHS right addend (number)
+ # 9. RHS right addend (number's decimal places) -- used for grouping, not capture
+ #
+
if (defined $3 or defined $7) {
- do_add($1, $3, $7);
- } elsif (defined $3 and defined $8) {
+ do_add($1, $2, $6);
+ } elsif (defined $4 and defined $8) {
assign_var($1, (defined $5 or defined $9 ? 'N' : 'I'), $4 + $8);
} else {
printf(STDERR "jako: Syntax error in addition on line %d: '%s'\n", $line, $_);
@@ -823,7 +1403,7 @@
next;
}
- if (m/([A-Za-z][A-Za-z0-9]*)\s*[+]=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/) {
+ if (m/^([A-Za-z][A-Za-z0-9]*)\s*[+]=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/) {
if (defined $3) {
do_add($1, $1, $2);
} else {
@@ -832,7 +1412,7 @@
next;
}
- if (m/([A-Za-z][A-Za-z0-9_]*)\s*[+][+]$/) {
+ if (m/^([A-Za-z][A-Za-z0-9_]*)\s*[+][+]$/) {
do_inc($1);
next;
}
@@ -856,11 +1436,25 @@
#
# a--; # dec_[in]
#
+
+ if
+(m/^([A-Za-z][A-Za-z0-9]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))\s*[-]\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/)
+ {
+ #
+ # Regexp Captures:
+ #
+ # 1. LHS difference (variable name)
+ # 2. RHS minuend
+ # 3. RHS minuend (variable name)
+ # 4. RHS minuend (number)
+ # 5. RHS minuend (number's decimal places) -- used for grouping, not capture
+ # 6. RHS subtrahend
+ # 7. RHS subtrahend (variable name)
+ # 8. RHS subtrahend (number)
+ # 9. RHS subtrahend (number's decimal places) -- used for grouping, not capture
+ #
- if
(m/([A-Za-z][A-Za-z0-9]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))\s*[-]\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/)
{
if (defined $3 or defined $7) {
- do_sub($1, $3, $7);
- } elsif (defined $3 and defined $8) {
+ do_sub($1, $2, $6);
+ } elsif (defined $4 and defined $8) {
assign_var($1, (defined $5 or defined $9 ? 'N' : 'I'), $4 - $8);
} else {
printf(STDERR "jako: Syntax error in subtraction on line %d: '%s'\n", $line,
$_);
@@ -868,7 +1462,7 @@
next;
}
- if (m/([A-Za-z][A-Za-z0-9]*)\s*[-]=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/) {
+ if (m/^([A-Za-z][A-Za-z0-9]*)\s*[-]=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/) {
if (defined $3) {
do_sub($1, $1, $2);
} else {
@@ -877,7 +1471,7 @@
next;
}
- if (m/([A-Za-z][A-Za-z0-9_]*)\s*[-][-]$/) {
+ if (m/^([A-Za-z][A-Za-z0-9_]*)\s*[-][-]$/) {
do_dec($1, 1);
next;
}
@@ -900,10 +1494,24 @@
# a *= 3.14; # mul_n_nc (pseudo-op)
#
- if
(m/([A-Za-z][A-Za-z0-9]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))\s*[*]\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/)
{
+ if
+(m/^([A-Za-z][A-Za-z0-9]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))\s*[*]\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/)
+ {
+ #
+ # Regexp Captures:
+ #
+ # 1. LHS product (variable name)
+ # 2. RHS multiplicand
+ # 3. RHS multiplicand (variable name)
+ # 4. RHS multiplicand (number)
+ # 5. RHS multiplicand (number's decimal places) -- used for grouping, not capture
+ # 6. RHS multiplier
+ # 7. RHS multiplier (variable name)
+ # 8. RHS multiplier (number)
+ # 9. RHS multiplier (number's decimal places) -- used for grouping, not capture
+ #
+
if (defined $3 or defined $7) {
- do_mul($1, $3, $7);
- } elsif (defined $3 and defined $8) {
+ do_mul($1, $2, $6);
+ } elsif (defined $4 and defined $8) {
assign_var($1, (defined $5 or defined $9 ? 'N' : 'I'), $4 * $8);
} else {
printf(STDERR "jako: Syntax error in multiplication on line %d: '%s'\n", $line,
$_);
@@ -911,7 +1519,7 @@
next;
}
- if (m/([A-Za-z][A-Za-z0-9]*)\s*[*]=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/) {
+ if (m/^([A-Za-z][A-Za-z0-9]*)\s*[*]=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/) {
do_mul($1, $1, $2);
next;
}
@@ -933,11 +1541,27 @@
# a /= 5; # div_i_ic (pseudo-op)
# a /= 3.14; # div_n_nc (pseudo-op)
#
+
+ if
+(m/^([A-Za-z][A-Za-z0-9]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)?))\s*[\/]\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)?))$/)
+ {
+ #
+ # Regexp Captures:
+ #
+ # 1. LHS quotient (variable name)
+ # 2. RHS dividend
+ # 3. RHS dividend (variable name)
+ # 4. RHS dividend (number)
+ # 5. RHS dividend (number's decimal places) -- used for grouping, not capture
+ # 6. RHS divisor
+ # 7. RHS divisor (variable name)
+ # 8. RHS divisor (number)
+ # 9. RHS divisor (number's decimal places) -- used for grouping, not capture
+ #
- if
(m/([A-Za-z][A-Za-z0-9]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))\s*[\/]\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/)
{
+ push_source "$1 = $2 / $6";
+
if (defined $3 or defined $7) {
- do_div($1, $3, $7);
- } elsif (defined $3 and defined $8) {
+ do_div($1, $2, $6);
+ } elsif (defined $4 and defined $8) {
assign_var($1, (defined $5 or defined $9 ? 'N' : 'I'), $4 / $8);
} else {
printf(STDERR "jako: Syntax error in division on line %d: '%s'\n", $line, $_);
@@ -945,7 +1569,7 @@
next;
}
- if (m/([A-Za-z][A-Za-z0-9]*)\s*[\/]=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/) {
+ if (m/^([A-Za-z][A-Za-z0-9]*)\s*[\/]=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+(\.\d+)))$/) {
do_div($1, $1, $2);
next;
}
@@ -964,12 +1588,14 @@
# a %= 4;
#
- if
(m/([A-Za-z][A-Za-z0-9]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+))\s*[%]\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+))$/)
{
+ if
+(m/^([A-Za-z][A-Za-z0-9]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+))\s*[%]\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+))$/)
+ {
+ push_source "$1 = $2 \% $5";
do_mod($1, $2, $5);
next;
}
- if (m/([A-Za-z][A-Za-z0-9]*)\s*[%]=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+))$/) {
+ if (m/^([A-Za-z][A-Za-z0-9]*)\s*[%]=\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+))$/) {
+ push_source "$1 \%= $2";
do_mod($1, $1, $2);
next;
}
@@ -983,12 +1609,12 @@
# TODO: Can't really support shift amount as arg until sh[lr]_i_i ops are
implemented.
#
- if
(m/([A-Za-z][A-Za-z0-9]*)\s*=\s*([A-Za-z][A-Za-z0-9_]*)\s*(<<|>>)\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+))$/)
{
+ if
+(m/^([A-Za-z][A-Za-z0-9]*)\s*=\s*([A-Za-z][A-Za-z0-9_]*)\s*(<<|>>)\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+))$/)
+ {
do_shift($3 eq '<<' ? 'l' : 'r', $1, $2, $4);
next;
}
- if (m/([A-Za-z][A-Za-z0-9]*)\s*((<<|>>)=)\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+))$/) {
+ if (m/^([A-Za-z][A-Za-z0-9]*)\s*((<<|>>)=)\s*(([A-Za-z][A-Za-z0-9_]*)|(\d+))$/) {
do_shift($4 eq '<<' ? 'l' : 'r', $1, $2, $5);
next;
}
@@ -998,12 +1624,14 @@
#
if (m/^end$/) {
- printf "%-12s %-8s\n", '', 'end';
+ emit_code('end');
next;
}
print STDERR "jako: Syntax error on line $line: '$_'.\n";
}
+
+emit_code('end') unless $last_op eq 'end';
exit 0;
#
# primes.jako
#
# A simple program to print out the primes up to 100.
#
# Based on a Parrot assembly example by Leon Brocard <[EMAIL PROTECTED]>
#
# Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
# This program is free software. It is subject to the same
# license as Perl itself.
#
# $Id: $
#
const int n = 100;
var int i = 2;
print("Algorithm P (Naiive primality test)\n");
print(" Printing primes up to $n...\n");
NUMBER: while (i <= n) {
var int m;
var int j = 2;
m = i / 2;
FACTOR: while (j <= m) {
var int x;
x = i % j;
if (x == 0) {
next NUMBER;
}
j++;
}
print("$i ");
} continue {
i++;
}
print("\n");
###############################################################################
# This Parrot assembler file was produced by the Jako compiler. #
# Initial comments from the source code are reproduced below. #
###############################################################################
#
# primes.jako
#
# A simple program to print out the primes up to 100.
#
# Based on a Parrot assembly example by Leon Brocard <[EMAIL PROTECTED]>
#
# Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
# This program is free software. It is subject to the same
# license as Perl itself.
#
# $Id: $
#
# const int n = 100;
# var int i;
set I1, 2 # i = 2
print "Algorithm P (Naiive primality test)\n"
print " Printing primes up to "
print 100
print "...\n"
NUMBER_WHILE:
NUMBER_NEXT: set I0, 100 # NUMBER: while (i <= n) {
gt I1, I0, NUMBER_LAST
# var int m;
# var int j;
NUMBER_REDO: set I3, 2 # j = 2
set I0, 2 # m = i / 2
div I2, I1, I0
FACTOR_WHILE:
FACTOR_NEXT: gt I3, I2, FACTOR_LAST # FACTOR: while (j <= m) {
# var int x;
FACTOR_REDO: mod I4, I1, I3 # x = i % j
_I3_IF:
_I3_TEST: set I0, 0 # _I3: if (x == 0) {
ne I4, I0, _I3_ELSE
_I3_REDO: branch NUMBER_CONT # next NUMBER
# }
_I3_ELSE: inc I3 # I3++
FACTOR_CONT: branch FACTOR_NEXT # }
FACTOR_LAST: print ""
print I1
print " "
# } continue {
NUMBER_CONT: inc I1 # I1++
branch NUMBER_NEXT # }
NUMBER_LAST: print "\n"
end
