#! /usr/bin/perl
##### Underlambda reference interpreter.
##### Implements tiers 1 to 5a
#### Options
use strict;
$|=1; # output immediately, as is usual for esolangs
#### Subroutines and data.
### Grammar for Underlambda, which is extremely simple:
my ($udldcmd, $udldgroup, $udldcmdns, $udldgroupns);
# A command is a group, or any character but a paren.
$udldcmd=qr/[^()]|(??{$udldgroup})/s;
# A group is a list of commands inside parens.
$udldgroup=qr/\((??{$udldcmd})*\)/s;
# It's also useful to have \-less versions of these.
$udldcmdns=qr/[^()\\]|(??{$udldgroupns})/s;
$udldgroupns=qr/\((??{$udldcmdns})*\)/s;
### Reporting warnings and errors.
## udldwarn: Show a warning.
sub udldwarn ($)
{
my $msg = shift;
print STDERR "Warning: $msg\n";
}
## udlderror: Error out.
sub udlderror ($)
{
my $msg = shift;
print STDERR "Error: $msg\n";
exit 1;
}
### Helper functions
## charcount: Number of occurrences of the second arg in the first.
sub charcount ($$)
{
my $string = shift;
my $char = shift;
scalar(split $char,$string);
}
## errifundef: Returns its argument, or errors using the second argument
## as the error message if its argument happens to be undef.
sub errifundef ($$)
{
my $arg = shift;
defined($arg) or udlderror shift;
$arg;
}
## tochurch: Return the Church numeral corresponding to the argument
sub tochurch ($)
{
my $num = shift;
$num eq '0' ? "(!())" : "(".(":"x($num-1)).("*"x($num-1)).")";
}
## tostring: Return a string of Church numerals of char codes.
sub tostring ($)
{
my @chars = split //, shift;
local $" = "";
@chars = map {tochurch(ord($_));} @chars;
"(@chars)";
}
### Input and output, Underlambda style
## udldgetc: Input a character.
sub udldgetc ()
{
my $char=getc(STDIN);
defined($char) ? ord($char)+1 : 0;
}
## udldputc: Output a character.
sub udldputc ($)
{
my $char=shift;
$char == 0 and udlderror "Attempt to output an EOF";
print chr($char-1);
}
## udldgetserial: Input a serialisation.
sub udldgetserial ()
{
local $_='';
local $/=')';
# Anything's a legitimate serialisation as long as it has balanced
# parentheses and doesn't contain the characters {}#|
$_ .= (errifundef <>, "D command couldn't deserialise: EOF on input")
while (charcount $_, "(") > (charcount $_, ")");
(charcount $_, "(") == (charcount $_, ")")
or udlderror "D command couldn't deserialise: unbalanced ()";
m/[{}#|]/
and udlderror "D command couldn't deserialise: invalid character";
$_;
}
#### The main program.
### Read in the program.
my $magic=<>; # the first line
$_="";
if($magic =~ /\n/)
{
local $/=undef;
$_=<>; # the rest
}
if($magic !~ m%^#!/usr/bin/env underlambda%)
{
udldwarn 'Magic line "#!/usr/bin/env underlambda" not found.';
$_=$magic.$_;
}
else
{
# Parse command line options: //tk
}
## Check the input validity.
s/\s*$//s; # remove trailing whitespace
s/\|$// or udldwarn 'No | found at end of program.';
m/\|/ and udlderror '| found before end of program.';
m/#/ and udlderror '# found after start of program.';
m/\{/ and udlderror '{ found within program.';
m/\}/ and udlderror '} found within program.';
/^(??{$udldcmd})*$/ or udlderror '() not matched in program.';
### Storage needed for the program.
my $iocharcode = undef;
my @storestack = ();
### Execute the program. The combined code/data model is used;
### that is, the stack is stored in the program itself, which is
### less efficient but makes serialising easy, and can optimise
### inert code. Note that this method means that the () command
### doesn't need to be executed.
{
print "$_\n";
## Tier 5 and 5a: Preprocessing.
# (These rules MUST be run in this sequence, as they have a higher
# priority than the other rules and a fixed priority themselves.)
# They don't run at all, they're more preprocessor-type rules.
s/"(??{$udldcmd})*"/tostring($1)/e and redo; # "
s/'\.([^#|\[\](){}])/"(".tochurch(ord($1)).";)"/e and redo; # '.
s/\.([^#|\[\](){}])/tochurch(ord($1)).";"/e and redo; # .
s/'((??{$udldgroup}))/(($1))/ and redo; # '
s/'([^#|\[\](){}])/($1)/ and redo;
# Lambdas; these rules together implement \.
s/((??{$udldgroup}))\\([wxyz])\\([wxyz])/($1\\$2)\\$3^/ and redo;
s/((??{$udldgroup}))\\([wxyz])\^\\([wxyz])/($1\\$2^)\\$3^/
and redo;
s/\(((??{$udldcmdns})*)((??{$udldgroupns}))((??{$udldcmdns})*)\)\\([wxyz])
/::$2\\$4a~($3)\\$4*~($1)\\$4~*/x and redo;
s/\(((??{$udldcmdns})*)([wxyz])((??{$udldcmdns})*)\)\\\2
/::($3)\\$2*~($1)\\$2~*/x and redo;
s/((??{$udldgroupns}))\\([wxyz])/!$1/ and redo;
## Some optimisations; these are run before the other non-tier-5 rules.
s/:~/:/ and redo;
s/:!// and redo;
s/a\^// and redo;
s/\(\)\*// and redo;
s/\(\)~\*// and redo;
s/~~// and redo;
## Tier 1: Basic TCness
# Out-of-sequence-safe commands
s/(??{$udldgroup})!// and redo; # !
s/\(((??{$udldcmd})*)\)\^/$1/ and redo; # ^
s/\(((??{$udldcmd})*)\)\(((??{$udldcmd})*)\)\*/($1$2)/ and redo; # *
s/((??{$udldgroup}))((??{$udldgroup}))~/$2$1/ and redo; # ~
s/((??{$udldgroup}))a/($1)/ and redo; # a
# Commands that must be run in sequence
s/^((??{$udldgroup})*)((??{$udldgroup})):/$1$2$2/ and redo; # :
## Tier 1a: Basic character I/O
# All of these must be run in sequence
s/^((??{$udldgroup})*)o/($iocharcode = 0),$1/e and redo; # o
s/^((??{$udldgroup})*)i/($iocharcode = udldgetc),$1/e and redo; # i
s/^((??{$udldgroup})*)h/($iocharcode++),$1/e and redo; # h
s/^((??{$udldgroup})*)O/(udldputc $iocharcode),$1/e and redo; # O
s/^((??{$udldgroup})*)((??{$udldgroup}))I/
$iocharcode?"$1$2":"$1()"/e and redo; # I
s/^((??{$udldgroup})*)H/($iocharcode-- < 0 and
udlderror "IO character has gone negative"),$1/e and redo; # H
## Tier 2: Manipulating the program itself
# All of these must be run in sequence
m/^((??{$udldgroup})*)Q/ and exit 0; # Q
s/^((??{$udldgroup})*)C(.*)$/$1($1($2))$2/ and redo; # C
## Tier 2a: Serialisation
s/^((??{$udldgroup})*)((??{$udldgroup}))S/(print $2),$1/e and redo; # S
s/^((??{$udldgroup})*)D/$1.udldgetserial/e and redo; # D
## Tier 3: Stack manipulation
s/^((??{$udldgroup})*)((??{$udldgroup}))>/
(push @storestack, $2), $1/e and redo; # >
s/^>/(push @storestack, $2), ""/e and redo;
s/^((??{$udldgroup})*)</"$1(".(pop @storestack).")"/e and redo; # <
s/^(??{$udldgroup})*A// and redo; # A
s/^(??{$udldgroup})n/()/ and redo; # n
s/^((??{$udldgroup}){2,})n/$1/ and redo;
## Tier 4: Church numerals
# All these are out-of-sequence-safe
s/([0-9]+)/tochurch($1)/e and redo; # num
s/\s// and redo; # space
s/\(((??{$udldcmd})*)\)\+/(:$1*)/ and redo; # +
s/\(((??{$udldcmd})*)\)\-/((:)$1(!!()())*(*)$1*)(!(!()))(!())$1^^/
and redo; # -
s/\(((??{$udldcmd})*)\)p/(+)$1^/ and redo; # p
s/\(((??{$udldcmd})*)\)m/(-)$1^/ and redo; # m
## Tier 4a: Character code I/O
s/\(((??{$udldcmd})*)\);/o(h)$1^O/ and redo; # p
s/\?/i(!())(I(H~(:)~*(*)*~^)I^^):^/ and redo; # ?
}