##### 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
}