134 lines
3.3 KiB
Perl
134 lines
3.3 KiB
Perl
#!/usr/bin/perl
|
|
use warnings;
|
|
use strict;
|
|
use v5.10;
|
|
|
|
=for starters
|
|
|
|
Syntax:
|
|
|
|
if2 condition1, condition2, then2 {
|
|
# both conditions are true
|
|
}
|
|
else1 {
|
|
# only condition1 is true
|
|
}
|
|
else2 {
|
|
# only condition2 is true
|
|
}
|
|
orelse {
|
|
# neither condition is true
|
|
};
|
|
|
|
Any (but not all) of the `then' and `else' clauses can be omitted, and else1
|
|
and else2 can be specified in either order.
|
|
|
|
This extension is imperfect in several ways:
|
|
* A normal if-statement uses round brackets, but this syntax forbids them.
|
|
* Perl doesn't have a `then' keyword; if it did, it probably wouldn't be
|
|
preceded by a comma.
|
|
* Unless it's the last thing in a block, the whole structure must be followed
|
|
by a semicolon.
|
|
* Error messages appear at runtime, not compile time, and they don't show the
|
|
line where the user's syntax error occurred.
|
|
|
|
We could solve most of these problems with a source filter, but those are
|
|
dangerous. Can anyone else do better? Feel free to improve or replace.
|
|
|
|
=cut
|
|
|
|
# All the new `keywords' are in fact functions. Most of them return lists
|
|
# of four closures, one of which is then executed by if2. Here are indexes into
|
|
# these lists:
|
|
|
|
use constant {
|
|
IdxThen => 0,
|
|
IdxElse1 => 1,
|
|
IdxElse2 => 2,
|
|
IdxOrElse => 3
|
|
};
|
|
|
|
# Most of the magic is in the (&) prototype, which lets a function accept a
|
|
# closure marked by nothing except braces.
|
|
|
|
sub orelse(&) {
|
|
my $clause = shift;
|
|
return undef, undef, undef, $clause;
|
|
}
|
|
|
|
sub else2(&@) {
|
|
my $clause = shift;
|
|
die "Can't have two `else2' clauses"
|
|
if defined $_[IdxElse2];
|
|
|
|
return (undef, $_[IdxElse1], $clause, $_[IdxOrElse]);
|
|
}
|
|
|
|
sub else1(&@) {
|
|
my $clause = shift;
|
|
die "Can't have two `else1' clauses"
|
|
if defined $_[IdxElse1];
|
|
|
|
return (undef, $clause, $_[IdxElse2], $_[IdxOrElse]);
|
|
}
|
|
|
|
sub then2(&@) {
|
|
die "Can't have two `then2' clauses"
|
|
if defined $_[1+IdxThen];
|
|
|
|
splice @_, 1+IdxThen, 1;
|
|
return @_;
|
|
}
|
|
|
|
# Here, we collect the two conditions and four closures (some of which will be
|
|
# undefined if some clauses are missing). We work out which of the four
|
|
# clauses (closures) to call, and call it if it exists.
|
|
|
|
use constant {
|
|
# Defining True and False is almost always bad practice, but here we
|
|
# have a valid reason.
|
|
True => (0 == 0),
|
|
False => (0 == 1)
|
|
};
|
|
|
|
sub if2($$@) {
|
|
my $cond1 = !!shift; # Convert to Boolean to guarantee matching
|
|
my $cond2 = !!shift; # against either True or False
|
|
|
|
die "if2 must be followed by then2, else1, else2, &/or orelse"
|
|
if @_ != 4
|
|
or grep {defined and ref $_ ne 'CODE'} @_;
|
|
|
|
my $index;
|
|
if (!$cond1 && !$cond2) {$index = IdxOrElse}
|
|
if (!$cond1 && $cond2) {$index = IdxElse2 }
|
|
if ( $cond1 && !$cond2) {$index = IdxElse1 }
|
|
if ( $cond1 && $cond2) {$index = IdxThen }
|
|
|
|
my $closure = $_[$index];
|
|
&$closure if defined $closure;
|
|
}
|
|
|
|
# This is test code. You can play with it by deleting up to three of the
|
|
# four clauses.
|
|
|
|
sub test_bits($) {
|
|
(my $n) = @_;
|
|
|
|
print "Testing $n: ";
|
|
|
|
if2 $n & 1, $n & 2, then2 {
|
|
say "Both bits 0 and 1 are set";
|
|
}
|
|
else1 {
|
|
say "Only bit 0 is set";
|
|
}
|
|
else2 {
|
|
say "Only bit 1 is set";
|
|
}
|
|
orelse {
|
|
say "Neither bit is set";
|
|
}
|
|
}
|
|
|
|
test_bits $_ for 0 .. 7;
|