I'll show you mine...

Okay, this is the beginnings of Scheme in Perl6. I'm sure there's
stuff I'm getting wrong. I've not written the parser yet for instance
and I'm toying with waiting for A5 before I do. Also, I've not yet
implemented such important stuff as proper closures/lambda or the
environment chain, but the underpinning structure is there.

I'm also deeply uncertain about the workings of overloading and of
operator declaration so those bits are probably wrong.

---SNIP---

module SchemeInterpreter;

class SchemeExpr {
  use overload 
    '""' => 'raw_string',
    '0+' => 'to_number',
    fallback => 1
  ;

  my SchemeExpr $.value;

  method new($proto: $val) {
    my $s = $proto.SUPER::new but true;
    $s.set_value( $val );
    $s;
  }

  method value { $.value }
  method set_value($s: SchemeExpr $val) { $.value = $val; $s }

  method raw_string { "$.value" }
  method display_string { .raw_string }

  method evaluate($s: $context) { $s } 

  method AUTOLOAD {
    my($method) = ($AUTOLOAD =~ m/.*::(.*)/);
    my $self = shift;
    $self."NEXT::$method"(*@_) unless $method =~ /^is_/;
    return;
  }
}

class SchemeBoolean is SchemeExpr {
  my($t, $f);

  method new($proto: $val) {
    given $val {
      when '#t' { $t //= $proto.SUPER::new($val) }
      when '#f' { $f //= $proto.SUPER::new($val) but false }
      default { $proto.new( $val ?? '#t' :: '#f' ) }
    }
  }

  method is_boolean { 1 }
}

class SchemeNumber is SchemeExpr {
  my sub apply($self: $target, $rhs, &block) {
    if $is_rhs { $self.new(+ &block( $target, $self.value )) }
    else       { $self.new(+ &block( $self.value, $target )) }
  }
   
  method operator:+ { apply(*@_, {$^a + $^b}) }
  method operator:* { apply(*@_, {$^a * $^b}) }
  method operator:- { apply(*@_, {$^a * $^b}) }
  method operator:/ { apply(*@_, {$^a * $^b}) }

  method is_number { 1 }
}

class SchemePair is SchemeExpr {
  my $nil //= class is SchemeExpr {
    method is_nil {1}
    method car { fail Exception:
                 msg => "car: expects argument of type <pair>, given ()" }
    method cdr { fail Exception:
                 msg => "cdr: expects argument of type <pair>, given ()" }
  }.new('()');

  method new($proto: PAIR $val) { $proto.SUPER::new($val) }

  method cons($proto: SchemeExpr $car, SchemeExpr $cdr) {
    $proto.new( $car => $cdr )
  }

  method car { .value.key }
  method cdr { .value.value }
  method is_pair { 1 }

  method as_array($s:) {
    my @ary;
    my $l = .cons($nil, $s);

    while ($.is_pair) {
      push @ary, $l.car;
      $l = $l.cdr;
    }
    push @ary, $l;
    return @ary;
  }
  
  method raw_string {
    my @ary = .as_array;
    if @ary[-1].is_nil { @ary.pop; "(@ary)" }
    else { my $last = @ary.pop; "(@ary . $last)" }
  }

  method evaluate($self: $context) {
    $context.eval_list($self)
  }

  method length($self:) {
    my @ary = $self.as_array;
    unless @ary[-1].is_nil {
      fail Exception:
        msg => "length: expects argument of type <proper list>; given $self";
    @ary.length - 1;
  }

  method AUTOLOAD {
    .NEXT::AUTOLOAD unless $AUTOLOAD =~ /:?c([ad]+)r$/;
    my @ops = reverse split '', $1;
    my $val = $_[0];
    for @ops -> $type {
      $val = $val."c${type}r";
    }
    return $val;
  }
}

class SchemeSymbol is SchemeExpr {
  my %symcache;

  method new($name) {
    %symcache{"$name"} //= .SUPER::new("$name");
  }
  method is_symbol { 1 };
  method evaluate($self: $context) {
    $context.eval_symbol($self);
  }
}

class SchemePrimitive is SchemeExpr {
  method new($proto: PAIR $val) {
    $proto.SUPER::new($val)
  }

  method is_primitive { 1 };
  method raw_string { "#<primitive:" _ .value.key _ ">" }
  
  method apply($self: SchemeExpr $expr, $context) {
    $self.value.value($expr, $context)
  }
}
  


class SchemeEnvironment is HASH {
  my $the_null_envt = class {
    method exists { }
    method bind { fail "You can't bind anything in the null environment" }
    method set { fail "You can't set anything in the null environment" }
    method get($symbol) { fail "reference to undefined identifier: $symbol" }
  }.new;

  method init {
    .{__parent__} //= $the_null_envt;

  method new_scope($self:) { ref($self).new(__parent__ => $self) }

  method bind_primitive($name, &func) {
    .bind(SchemeSymbol.new($name), 
          SchemePrimitive.new( $name => &func ));
  }

  my method parent { .{__parent__} }
  
  method set($self: SchemeSymbol $key, SchemeExpr $value) {
    given .exists($key) {
      when defined { .value($value) }
      default { fail "cannot set undefined identifier: $key" }
    }
    return $self;
  }

  method bind($self: SchemeSymbol $key, SchemeExpr $val) {
    .{$key} = $value;
    return $self;
  }
}  

class MathEvaluator {
  method evaluate($self: SchemeExpr $expr) {
    $expr.evaluate($self);
  }

  method eval_list($self: SchemePair $list) {
    my($op, $a, $b, @rem) = $list.as_array;
    
    fail Exception:
      msg => "Malformed expression $list. Expect (<op> <arg> <arg>)"
        if @rem.length;

    $a.evaluate($self); $b.evaluate($self);

    given $op {
      when "plus"     { $a + $b }
      when "minus"    { $a - $b }
      when "times"    { $a * $b }
      when "quotient" { $a / $b }
      default { fail Exception: 
                  msg => "Invalid operation in expr: $list" }
    }
  }
}

class SimpleSchemeEvaluator {
  my $.env;

  method init {
    $.env = SchemeEnvironment.new
    $.env.bind_primitive(
      '+' => $expr, $context -> {
               my $l = $expr;
               my $total = SchemeNumber.new(0);
               while $l {
                 when .is_nil { return $total }
                 default { $total += .car.evaluate($context);
                           $l = .cdr }
               }
             });
    $.env.bind_primitive(      
      '-' => $expr, $context -> {
               my $l = $expr.cdr;
               my $difference = $expr.car.evaluate($context);
               
               while $l {
                 when .is_nil { return $difference }
                 default { $total += .car.evaluate($context);
                           $l = .cdr }
               }
             });
    $.env.bind_primitive(
      '*' => my sub product($expr, $context) {
               my $l = $expr.cdr;
               my $product = SchemeNumber.new(1);
               
               while $l {
                 when .is_nil { return $product }
                 default { $product *= .car.evalate($context);
                           $l = .cdr }
               }
             });
    $.env.bind_primitive( '/' => { SchemeNumber.new(1) / product(*@_) } );
  }
  
  method evaluate($self: SchemeExpr $expr) {
    $expr.evaluate($self);
  }

  my %special_forms = (
    'define' => -> $pair, $context { $context.eval_define($pair) },
    'set!'   => -> $pair, $context { $context.eval_set($pair) },
    'if'     => -> $pair, $context { $context.eval_if($pair) },
  )

  method evaluate_list($self: SchemePair $pair) {
    given $pair.car {
      when %special_forms { %special_forms{$_}($pair.cdr, $self) }
      default { .evaluate($self).apply($pair.cdr, $self) }
    }
  }

  method eval_if($self: SchemePair $pair) {
    if ($pair.cadr.evaluate($self)) {
      $pair.caddr.evaluate($self)
    }
    else {
      $pair.length == 4
        ?? $pair.cadddr.evaluate($self)
        :: SchemeBoolean.new('#f')
    }
  }

  method eval_define($self: SchemePair $expr ) {
    unless $expr.length == 3 {
      fail "define: bad syntax (zero or multiple expressions " _
           "after identifier) in: $expr";
    }
    given $expr.cadr {
      when .is_symbol { $.env.bind( $_, 
                                    $expr.caddr.evaluate($self)) }
      default { fail "define: first argument must be a <symbol> in: $expr" }
    }
  }

  method eval_set($self: SchemePair $expr) {
    unless $expr.length == 3 {
      fail "set!: bad syntax (zero or multiple expressions " _
           "after identifier) in: $expr";
    }
    given $expr.cadr {
      when .is_symbol { $.env.set( $_,
                                    $expr.caddr.evaluate($self)) }
      default { fail "set!: first argument must be a <symbol> in: $expr" }
    }
  }
}

1;

---SNIP---

As you can see, docs are sparse.

However, in use i'd expect it to look like:

   my $evaluator = SimpleSchemeEvaluator.new;
   my $parser = SchemeParser.new(fh => $*STDIN);

   while 1 {
     $evaluator.evaluate($parser.get_expr);
   }

Note that the design is such that one could, in principle do

   my $compiler = SchemeCompiler.new;
   my $parser = SchemeParser.new(fh => "some_file".open_as_file);
   

   $compiler.evaluate($parser.get_expr) while ! $parser.is_finished;

   print $compiler.as_parrot_code;
   # eval $compiler.as_perl6_code;

It's just a simple matter of programming.

-- 
Piers

   "It is a truth universally acknowledged that a language in
    possession of a rich syntax must be in need of a rewrite."
         -- Jane Austen?

• I'll show you mine... by Piers Cawley
• Re: I'll show you mine... by raptor
• Re: I'll show you mine... by Melvin Smith
• Re: I'll show you mine... by Piers Cawley
• Re: I'll show you mine... by Piers Cawley
• Re: I'll show you mine... by Dan Sugalski
• Re: I'll show you mine... by Aaron Sherman
• Re: I'll show you mine... by Piers Cawley
• Re: I'll show you mine... by Dan Sugalski
• Re: I'll show you mine... by merlyn
• Re: I'll show you mine... by Dan Sugalski