Data commit

Task/Extend-your-language/Perl/extend-your-language-1.pl

@@ -0,0 +1,134 @@
+#!/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;

Task/Extend-your-language/Perl/extend-your-language-2.pl

@@ -0,0 +1,10 @@
+msl@64Lucid:~/perl$ ./if2
+Testing 0: Neither bit is set
+Testing 1: Only bit 0 is set
+Testing 2: Only bit 1 is set
+Testing 3: Both bits 0 and 1 are set
+Testing 4: Neither bit is set
+Testing 5: Only bit 0 is set
+Testing 6: Only bit 1 is set
+Testing 7: Both bits 0 and 1 are set
+msl@64Lucid:~/perl$