#!/usr/bin/env perl
# squishy2k.pl - v2000.10.06 Chris Pressey
# Squishy2K to Perl 5 compiler in Perl 5
# This work is in the public domain. See the file UNLICENSE for more
# information.
### SYNOPSIS
# squishy2k.pl - Squishy2K to Perl 5 compiler in Perl 5
# usage: [perl] squishy2k[.pl] <input.sq2k >output.pl
### GLOBALS
$token = '';
$line = '';
$curline = '';
### SCANNER
sub perr
{
my $msg = shift;
print "$msg\n";
print "($curline:$token)\n";
}
sub scan
{
restart_scan:
while (not defined $line or $line eq '')
{
if (defined($line = <STDIN>))
{
chomp $line;
$curline = $line;
} else
{
$line = ''; $token = '&&&EOF'; return;
}
}
if ($line =~ /^\/\//) { $line = ''; goto restart_scan; }
if ($line =~ /^\s+/) { $line = $'; goto restart_scan; }
if ($line =~ /^(\d+)/) { $line = $'; $token = $1; return; }
if ($line =~ /^([a-zA-Z_]\w*)/) { $line = $'; $token = $1; return; }
if ($line =~ /^(\".*?\")/) { $line = $'; $token = $1; return; }
if ($line =~ /^(\".*?)\s*$/) # exp. del. inform quotes
{
$token = $1;
$line = <INFILE>;
chomp $line;
while ($line !~ /^\s*(.*?\")/)
{
$token .= $line;
$line = <INFILE>;
chomp $line;
}
$line =~ /^\s*(.*?\")/;
$line = $';
$token .= " $1";
return;
}
if ($line =~ /^(.)/) { $line = $'; $token = $1; return; }
}
sub tokeq
{
return (uc($token) eq uc(shift));
}
sub tokne
{
return (uc($token) ne uc(shift));
}
sub expect
{
my $s = shift;
my $t = shift || 'unidentified production';
if(tokeq($s))
{
scan();
} else
{
perr "Expected '$s' not '$token' in '$t'";
# while (tokne($s)) { scan(); }
exit(0) if <STDIN> =~ /^q/;
}
}
### PARSER
# Program ::= {State}.
sub program
{
scan();
print "\$s = join('', <STDIN>); print \"\\n\";\n";
print "\$s =~ s/\\n/ /gos;\n";
while(tokeq('*')) { state(); }
expect('&&&EOF');
print "print main(\$s);\n";
}
# State ::= "*" Name "{" {Rule} ["!" Name] "}".
sub state
{
expect('*');
my $n = defn_name();
expect('{');
print "sub $n {\n";
print " my \$s = shift;\n";
# print " print \"$n...\\n\";\n";
while(tokne('}') and tokne('!')) { rule(); }
if(tokeq('!'))
{
scan();
my $q = apply_name();
print " \@_ = (\$s); goto \&$q;\n";
}
expect('}');
print " return \$s;\n";
print "}\n";
}
# Rule ::= String "?" String "!" [Name].
sub rule
{
my $a = lstring();
expect('?');
my $b = rstring();
expect('!');
if ($token =~ /^[a-zA-Z]\w+$/)
{
my $n = apply_name();
print " if(\$s =~ s/$a/$b/e) { \@_ = (\$s); goto \&$n; }\n";
} else
{
print " if(\$s =~ s/$a/$b/e) { return \$s; }\n";
}
}
sub defn_name
{
my $n = $token;
scan();
return $n;
}
sub apply_name
{
my $n = $token;
scan();
return $n;
}
# LString ::= {quoted | "few" | "many" | "start" | "finish"}.
sub lstring
{
my $s = '';
while ($token =~ /^\".*?\"$/ or
$token eq 'start' or $token eq 'finish' or
$token eq 'few' or $token eq 'many')
{
my $t = $token;
if ($t eq 'few')
{
$s .= "(.*?)";
} elsif ($t eq 'many')
{
$s .= "(.*)";
} elsif ($t eq 'start')
{
$s .= "^";
} elsif ($t eq 'finish')
{
$s .= "\$";
} else
{
$t =~ s/^\"(.*?)\"$/$1/;
$s .= quotemeta($t);
}
scan();
}
return $s;
}
# RString ::= {quoted | digit | Name "(" RString ")"}.
sub rstring
{
my $s = '""';
while ($token =~ /^\".*?\"$/ or
$token =~ /^\d+$/ or
$token =~ /^[a-zA-Z]\w*$/)
{
my $t = $token;
if ($t =~ /^[a-zA-Z]\w*$/)
{
$s .= " . $t(";
scan();
expect("(");
$s .= rstring();
expect(")");
$s .= ")";
} elsif ($t =~ /^\d+$/)
{
$s .= " . \$$t";
scan();
} else
{
$t =~ s/^\"(.*?)\"$/$1/;
$s .= " . \"" . quotemeta($t) . "\"";
scan();
}
}
return $s;
}
### MAIN
program();
### END