All --
I've made some more additions to the Jako compiler and changed the
examples, including the addtion of a factorial example based on
Leon Brocard's fact.pasm submission earlier today.
At this point, Jako is reasonably friendly for coding little
programs such as these. I'd like to encourage folks to try their
hand at writing more little programs to exercise it.
I'll keep adding features to the compiler until it gets to be too
much to handle without writing a real parser. Bear in mind that
the syntax looks almost like C or Perl, but it is parsed line-by-
line, which means you only get one statement per line, etc.
I'd like to use Jako as a test bed for the call/return stuff when
it is ready for prime time. I can add a user subroutine definition
syntax...
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
\_____________________________________________________________________/
#! /usr/bin/perl -w
#
# compile.pl - compile a Jako source file Parrot assembly file.
#
# Jako is a *very* simple language with just enough complexity to allow the
# implementation of little programs with while loops.
#
# * Global data only
# * No user subroutine definitions
#
# by Gregor N. Purdy <[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.
#
use strict;
#
# Global variables:
#
my $line; # Current source line number
my %ident; # Identifiers
my %regs = ( # Registers
I => [ undef ],
S => [ undef ]
);
my $block_count = 0;
my @block_stack = ();
#
# declare_var()
#
sub declare_var
{
my ($name, $type) = @_;
# 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",
$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";
$regs{$type}[$num]{LINE} = $line;
$regs{$type}[$num]{NAME} = $name;
print "# $name: $type$num\n";
return 1;
}
}
#
# assign_var()
#
sub assign_var
{
my ($name, $type, $value) = @_;
if ($ident{$name}) {
if ($type eq '*') {
if ($ident{$value}) {
printf "%-12s %-8s %s\n", '', '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";
} else {
printf(STDERR "jako: Assignment of %s variable from %s value not allowed on line %d.\n",
$ident{$name}{TYPE}, $type, $line);
}
} else {
printf(STDERR "jako: Assignment to undefined variable '%s' on line %d.\n",
$name, $line);
}
}
#
# map_args()
#
sub map_args
{
my (@args) = @_;
my @result;
foreach my $arg (@args) {
$arg =~ s/^\s+//;
$arg =~ s/\s+$//;
if ($ident{$arg}) {
push @result, $ident{$arg}{REG};
} elsif ($arg =~ m/^"/) {
push @result, $arg;
} elsif ($arg =~ m/^\d+$/) {
push @result, $arg;
} else {
printf(STDERR "jako: Unrecognized argument '%s' on line %d.\n", $arg, $line);
push @result, "<err>";
}
}
return @result;
}
#
# void_func()
#
sub void_func
{
my ($name, @args) = @_;
if ($name eq 'print') {
@args = map_args(@args);
foreach my $arg (@args) {
printf "%-12s %-8s %s\n", '', $name, $arg;
}
} else {
printf(STDERR "jako: Unrecognized function '$name' on line %d.\n", $name, $line);
}
}
#
# assign_func()
#
sub assign_func
{
my ($dest, $name, @args) = @_;
if ($name eq 'mod') {
@args = map_args($dest, @args);
printf "%-12s %-8s %s\n", '', $name, join(", ", @args);
} else {
printf(STDERR "jako: Unrecognized function '$name' on line %d.\n", $name, $line);
}
}
#
# begin_while_block()
#
sub begin_while_block
{
my ($cond) = @_;
$block_count++;
my $prefix = "_W$block_count";
push @block_stack, { TYPE => 'while', NEXT => $line, PREFIX => $prefix };
#
# TODO: Note that the assembler wasn't inferring the opcode qualifiers, so we had
# to code them explicitly. We should remove the qualifiers as soon as the
# assembler is fixed.
#
if ($cond =~ m/^(.*)\s*==\s*(.*)$/) {
my @args = map_args($1, $2);
printf "%-12s %-8s %s\n", "${prefix}_NEXT:", "eq_i_ic", "$args[0], $args[1], ${prefix}_REDO, ${prefix}_LAST";
printf "%s_REDO:\n", $prefix;
} elsif ($cond =~ m/^(.*)\s*!=\s*(.*)$/) {
my @args = map_args($1, $2);
printf "%-12s %-8s %s\n", "${prefix}_NEXT:", "ne_i_ic", "$args[0], $args[1], ${prefix}_REDO, ${prefix}_LAST";
printf "%s_REDO:\n", $prefix;
} elsif ($cond =~ m/^(.*)\s*<=\s*(.*)$/) {
my @args = map_args($1, $2);
printf "%-12s %-8s %s\n", "${prefix}_NEXT:", "le_i_ic", "$args[0], $args[1], ${prefix}_REDO, ${prefix}_LAST";
printf "%s_REDO:\n", $prefix;
} elsif ($cond =~ m/^(.*)\s*>=\s*(.*)$/) {
my @args = map_args($1, $2);
printf "%-12s %-8s %s\n", "${prefix}_NEXT:", "ge_i_ic", "$args[0], $args[1], ${prefix}_REDO, ${prefix}_LAST";
printf "%s_REDO:\n", $prefix;
} else {
printf(STDERR "jako: Syntax error. Unrecognized condition in while on line %d.\n", $line);
}
}
#
# begin_if_block()
#
sub begin_if_block
{
my ($cond) = @_;
$block_count++;
my $prefix = "_I$block_count";
push @block_stack, { TYPE => 'if', NEXT => $line, PREFIX => $prefix };
#
# TODO: Note that the assembler wasn't inferring the opcode qualifiers, so we had
# to code them explicitly. We should remove the qualifiers as soon as the
# assembler is fixed.
#
if ($cond =~ m/^(.*)\s*==\s*(.*)$/) {
my @args = map_args($1, $2);
printf "%-12s %-8s %s\n", "${prefix}_NEXT:", "eq_i_ic", "$args[0], $args[1], ${prefix}_REDO, ${prefix}_LAST";
printf "%s_REDO:\n", $prefix;
} elsif ($cond =~ m/^(.*)\s*!=\s*(.*)$/) {
my @args = map_args($1, $2);
printf "%-12s %-8s %s\n", "${prefix}_NEXT:", "ne_i_ic", "$args[0], $args[1], ${prefix}_REDO, ${prefix}_LAST";
printf "%s_REDO:\n", $prefix;
} elsif ($cond =~ m/^(.*)\s*<=\s*(.*)$/) {
my @args = map_args($1, $2);
printf "%-12s %-8s %s\n", "${prefix}_NEXT:", "le_i_ic", "$args[0], $args[1], ${prefix}_REDO, ${prefix}_LAST";
printf "%s_REDO:\n", $prefix;
} elsif ($cond =~ m/^(.*)\s*>=\s*(.*)$/) {
my @args = map_args($1, $2);
printf "%-12s %-8s %s\n", "${prefix}_NEXT:", "ge_i_ic", "$args[0], $args[1], ${prefix}_REDO, ${prefix}_LAST";
printf "%s_REDO:\n", $prefix;
} else {
printf(STDERR "jako: Syntax error. Unrecognized condition in while on line %d.\n", $line);
}
}
#
# end_block()
#
sub end_block
{
unless (@block_stack) {
printf(STDERR "jako: Syntax error. Closing brace without open block on line %d.\n", $line);
return;
}
my $block = pop @block_stack;
my $prefix = $block->{PREFIX};
#
# TODO: Note that the assembler wasn't inferring the opcode qualifiers, so we had
# to code them explicitly. We should remove the qualifiers as soon as the
# assembler is fixed.
#
if ($block->{TYPE} eq 'while') {
printf("%-12s %-8s %s\n", '', 'branch_ic', "${prefix}_NEXT", );
# TODO: Is there a better unconditional jump (branch_ic)?
}
printf "%s_LAST:\n", $prefix;
}
#
# do_next()
#
sub do_next
{
#
# TODO: Note that the assembler wasn't inferring the opcode qualifiers, so we had
# to code them explicitly. We should remove the qualifiers as soon as the
# assembler is fixed.
#
foreach (reverse @block_stack) {
if ($_->{TYPE} eq 'while') {
my $prefix = $_->{PREFIX};
printf("%-12s %-8s %s\n", '', 'branch_ic', "${prefix}_NEXT", );
last;
}
}
}
#
# do_last()
#
sub do_last
{
#
# TODO: Note that the assembler wasn't inferring the opcode qualifiers, so we had
# to code them explicitly. We should remove the qualifiers as soon as the
# assembler is fixed.
#
foreach (reverse @block_stack) {
if ($_->{TYPE} eq 'while') {
my $prefix = $_->{PREFIX};
printf("%-12s %-8s %s\n", '', 'branch_ic', "${prefix}_LAST", );
# TODO: Is there a better unconditional jump (branch_ic)?
last;
}
}
}
#
# do_redo()
#
sub do_redo
{
#
# TODO: Note that the assembler wasn't inferring the opcode qualifiers, so we had
# to code them explicitly. We should remove the qualifiers as soon as the
# assembler is fixed.
#
foreach (reverse @block_stack) {
if ($_->{TYPE} eq 'while') {
my $prefix = $_->{PREFIX};
printf("%-12s %-8s %s\n", '', 'branch_ic', "${prefix}_REDO", );
# TODO: Is there a better unconditional jump (branch_ic)?
last;
}
}
}
#
# do_add()
#
sub do_add
{
my ($dest, $a, $b) = @_;
printf("%-12s %-8s %s\n", '', 'add', join(", ", map_args($dest, $a, $b)));
}
#
# do_inc()
#
sub do_inc
{
my ($dest, $amount) = @_;
printf("%-12s %-8s %s\n", '', 'inc', join(", ", map_args($dest, 1)));
}
#
# do_mul()
#
sub do_mul
{
my ($dest, $a, $b) = @_;
printf("%-12s %-8s %s\n", '', 'mul', join(", ", map_args($dest, $a, $b)));
}
#
# parse_args()
#
sub parse_args
{
my ($args) = @_;
my @args;
while ($args ne '') {
$args =~ s/^\s+//;
if ($args =~ m/^(\"[^\\\"]*(?:\\.[^\\\"]*)*\")\s*(,\s*(.*))?$/) {
push @args, $1;
$args = $3 || '';
} elsif ($args =~ m/^([^,]+)\s*(,\s*(.*))?$/) {
push @args, $1;
$args = $3 || '';
} else {
printf(STDERR "jako: Syntax error. Cannot parse argument list '$args' on line %d.\n", $line);
return ();
}
}
return @args;
}
#
# MAIN PROGRAM:
#
print "# This file produced by the Jako Compiler\n";
while(<>) {
$line++;
if (m/\s*#/) { # Pass comment-only lines through intact.
print;
next;
}
chomp; # Trim trailing newline
s/^\s*//; # Trim leading whitespace
s/\s*$//; # Trim trailing whitespace
next if (/^\#/ || $_ eq ""); # Skip comment and blank lines
last if (/^__END__$/); # Done after __END__ token
s/\s*;\s*$//; # Remove trailing semicolons
if (m/^([A-Za-z][A-Za-z0-9_]*)\s+is\s+int(eger)?$/) {
declare_var($1, 'I');
next;
}
if (m/^([A-Za-z][A-Za-z0-9_]*)\s+is\s+string$/) {
declare_var($1, 'S');
next;
}
if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*(\d+)$/) {
assign_var($1, 'I', $2);
next;
}
if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*(\"[^\\\"]*(?:\\.[^\\\"]*)*\")$/) {
assign_var($1, 'S', $2);
next;
}
if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*([A-Za-z][A-Za-z0-9_]*)$/) {
assign_var($1, '*', $2);
next;
}
if (m/^([A-Za-z][A-Za-z0-9_]*)\((.*)\)$/) {
void_func($1, parse_args($2));
next;
}
if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*([A-Za-z][A-Za-z0-9_]*)\((.*)\)$/) {
assign_func($1, $2, split(/\s*,\s*/, $3));
next;
}
if (m/^while\s*\(\s*(.*)\s*\)\s*{$/) {
begin_while_block($1);
next;
}
if (m/^if\s*\(\s*(.*)\s*\)\s*{$/) {
begin_if_block($1);
next;
}
if (m/^}$/) {
end_block();
next;
}
if (m/^next$/) {
do_next();
next;
}
if (m/^last$/) {
do_last();
next;
}
if (m/^redo$/) {
do_redo();
next;
}
#
# Additive functions:
#
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_]*)$/) {
do_add($1, $2, $3);
next;
}
if (m/([A-Za-z][A-Za-z0-9_]*)\s*[+][+]$/) {
do_inc($1, 1);
next;
}
#
# Multiplicative functions:
#
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_]*)$/) {
do_mul($1, $2, $3);
next;
}
if (m/([A-Za-z][A-Za-z0-9]*)\s*[*]=\s*([A-Za-z][A-Za-z0-9_]*)$/) {
do_mul($1, $1, $2);
next;
}
#
# Miscellany:
#
if (m/^end$/) {
printf "%-12s %-8s\n", '', 'end';
next;
}
print STDERR "jako: Syntax error on line $line: '$_'.\n";
}
exit 0;
#
# End of file.
#
#
# euclid.jako
#
# Knuth, Donald E.
# The Art of Computer Programming
# Volume 1: Fundamental Algorithms
# Third Edition
#
# Section 1.1
# Algorithm E (Euclid's algorithm)
# Page 2
#
# Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
# This program is frees software. It is subject to the same
# license as Perl itself.
#
m is int;
n is int;
zero is int;
r is int;
s is string;
zero = 0;
m = 96;
n = 64;
print("Algorithm E (Euclid's algorithm)\n");
print(" Calculating gcd(", m, ", ", n, ") = ...\n");
r = mod(m, n);
while (r != zero) {
m = n;
n = r;
r = mod(m, n);
}
print(" ... = ", n, "\n");
end;
# This file produced by the Jako Compiler
#
# euclid.jako
#
# Knuth, Donald E.
# The Art of Computer Programming
# Volume 1: Fundamental Algorithms
# Third Edition
#
# Section 1.1
# Algorithm E (Euclid's algorithm)
# Page 2
#
# Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
# This program is frees software. It is subject to the same
# license as Perl itself.
#
# m: I1
# n: I2
# zero: I3
# r: I4
# s: S1
set I3, 0
set I1, 96
set I2, 64
print "Algorithm E (Euclid's algorithm)\n"
print " Calculating gcd("
print I1
print ", "
print I2
print ") = ...\n"
mod I4, I1, I2
_W1_NEXT: ne_i_ic I4, I3, _W1_REDO, _W1_LAST
_W1_REDO:
set I1, I2
set I2, I4
mod I4, I1, I2
branch_ic _W1_NEXT
_W1_LAST:
print " ... = "
print I2
print "\n"
end
#
# fact.jako
#
# Some simple code to print some factorials
#
# Based on fact.pasm originally be Leon Brocard <[EMAIL PROTECTED]> 2001-09-14.
#
# Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
# This program is free software. It is subject to the same
# license as Perl itself.
#
n is int;
i is int;
f is int;
n = 15;
print("Algorithm F1 (The factorial function)\n");
print(" Calculating fact(", n, ") = ...\n");
i = 0;
f = 1;
while(i <= n) {
i++;
f *= i;
}
print(" ... = ", f, "\n");
end;
# This file produced by the Jako Compiler
#
# fact.jako
#
# Some simple code to print some factorials
#
# Based on fact.pasm originally be Leon Brocard <[EMAIL PROTECTED]> 2001-09-14.
#
# Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
# This program is free software. It is subject to the same
# license as Perl itself.
#
# n: I1
# i: I2
# f: I3
set I1, 15
print "Algorithm F1 (The factorial function)\n"
print " Calculating fact("
print I1
print ") = ...\n"
set I2, 0
set I3, 1
_W1_NEXT: le_i_ic I2, I1, _W1_REDO, _W1_LAST
_W1_REDO:
inc I2, 1
mul I3, I3, I2
branch_ic _W1_NEXT
_W1_LAST:
print " ... = "
print I3
print "\n"
end
#
# fibo.jako
#
# Adapted from fibo.pasm by [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.
#
n is int;
i is int;
a is int;
b is int;
f is int;
n = 24;
print("Algorithm F2 (Fibonacci's function)\n");
print(" Calculating fib(", n, ") = ...\n");
a = 1;
b = 1;
f = 1;
i = 3;
while (i <= n) {
f = a + b;
a = b;
b = f;
i++;
}
print(" ... = ", f, "\n");
end;
# This file produced by the Jako Compiler
#
# fibo.jako
#
# Adapted from fibo.pasm by [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.
#
# n: I1
# i: I2
# a: I3
# b: I4
# f: I5
set I1, 24
print "Algorithm F2 (Fibonacci's function)\n"
print " Calculating fib("
print I1
print ") = ...\n"
set I3, 1
set I4, 1
set I5, 1
set I2, 3
_W1_NEXT: le_i_ic I2, I1, _W1_REDO, _W1_LAST
_W1_REDO:
add I5, I3, I4
set I3, I4
set I4, I5
inc I2, 1
branch_ic _W1_NEXT
_W1_LAST:
print " ... = "
print I5
print "\n"
end
