##### Underlambda reference interpreter.
##### Implements tier 1
#### Options
use strict;
$|=1; # output immediately, as is usual for esolangs
#### Subroutines and data.
### Grammar for Underlambda, which is extremely simple:
my ($udldcmd, $udldgroup);
# 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;
### 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;
}
### 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/underlambda%)
{
udldwarn 'Magic line "#!/usr/bin/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;
### 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.
{
## 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
}