Simple Lisp Interpreter

AUTHOR

Andrei Osipov

Inspired by http://www.norvig.com/lispy.html

use v6;



class Symbol {
    has $.name;

    method CALL-ME($x) {
        Symbol.new(name => $x);
    }

    method gist { "#<symbol:{$.name}>" }
    method Str  { $.name }
}

class Literal {
    has $.value;
    method CALL-ME($x) {
        Literal.new(value => $x)
    }

    method gist { '"' ~ $.value ~ '"' }
    method Str  {     ~ $.value       }
}

grammar Lisp::Grammar  {
    rule TOP {
       ^^ <statement>+ $$
    }

    rule statement {
        [ <sexp> |  <atom> ]
    }

    proto token bool { * }
    token bool:sym<true>    {  '#t'  }
    token bool:sym<false>   {  '#f'  }

    proto token number { * }
    token number:sym<integer> { <[-+]>?   \d+            }
    token number:sym<float>   { <[-+]>? [ \d+ ]? '.' \d+ }

    # TODO more number types

    proto token atom { * }

    token atom:sym<bool>   { <bool>   }
    token atom:sym<number> { <number> }
    token atom:sym<string> { <string> }
    token atom:sym<quote>  { <quote>  }
    token atom:sym<symbol> { <symbol> }

    token quote {
        \c[APOSTROPHE] <statement>
    }
    token symbol {
        <-[\c[APOSTROPHE]()\s]>+
    }
    rule sexp {
        '('  ~ ')' <statement>*
    }
    token string {
        \c[QUOTATION MARK] ~ \c[QUOTATION MARK]
        [ <str> | \\ <str=.str_escape> ]*
    }
    token str {
        <-[\c[QUOTATION MARK]\\\t\n]>+
    }

    token str_escape {
        <[\c[QUOTATION MARK]\\/bfnrt]>
    }
}

class List::Actons {
    method TOP($/) {
        make $<statement>Ā».made
    }

    method statement($/) {
        make $/.capsĀ».values.flatĀ».made[0]
    }

    method bool:sym<true>($/)  { make Symbol(~$/) }
    method bool:sym<false>($/) { make Symbol(~$/) }

    method number:sym<integer>($/) { make $/.Int }
    method number:sym<float>($/) { make $/.Rat }

    method atom:sym<bool>($/)   { make $<bool>.made   }
    method atom:sym<number>($/) { make $<number>.made }
    method atom:sym<string>($/) { make $<string>.made }
    method atom:sym<quote>($/)  { make $<quote>.made  }
    method atom:sym<symbol>($/) { make Symbol($<symbol>.made) }

    method atom($/) {
        make $/.capsĀ».values.flatĀ».made[0];
    }
    method quote($/) {
        make [ Symbol('quote'), $<statement>.made.Array ];
    }

    method symbol($/) {  make ~$/ }

    method sexp($/)    {
        make $/.capsĀ».values.flatĀ».made.Array;
    }

    method string($/) {
        my $str =  +@$<str> == 1
        ?? $<str>[0].made
        !! $<str>Ā».made.join ;

        make Literal($str);
    }

    method str($/) { make $/.Str }

    method str_escape($/) { make $/.Str }
}


sub parse-sexp(Str $str) {
    state $a = List::Actons.new();
    my $parse = Lisp::Grammar.parse($str,  :actions($a));

    return fail "syntax error" unless $parse;

    return $parse.ast[0];
}


class Func {
    has Callable $.code;
    has Str      $.desc;
    method eval(@a) { $.code.(|@a)   }
    method gist     { "#<{$.desc}>" }
}

class Env {
    has       %.scope is rw;
    has  Env  $.outer;

    method resolve($key) is rw {

        if %.scope{$key}:exists {
             %.scope{$key}
        }
        else {
            fail "unbound symbol '$key'" unless $.outer;
             $.outer.resolve($key);
        }
    }
    method merge(*@env) {
        %.scope = %.scope, %(@env)
    }
    multi method evaluate-tokens(Int $x) {
        $x
    }
    multi method evaluate-tokens(Rat $x) {
        $x
    }
    multi method evaluate-tokens(Symbol $x) {
        self.resolve($x)
    }
    multi method evaluate-tokens(Positional $x) {
        my @x = @($x);
        fail "Syntax error" if +@x == 0;
        my $verb = @x.shift;
        given $verb {
            when 'quote'   {
                fail "syntax error" if +@x > 1;
                @x[0];
            }
            when 'if'      {
                my ($test,
                    $conseq,
                    $alt) = @x;

                self.evaluate-tokens(
                    self.evaluate-tokens($test)
                    ?? $conseq
                    !! $alt
                )
            }
            when 'set!'    {
                my ($var, $exp) = @x;
                self.resolve($var) = self.evaluate-tokens($exp);
                #return $var;

            }
            when 'eval' {
                my ($quoted-sexp) = @x;
                self.evaluate-tokens($quoted-sexp[1]);
            }
            when 'define'  {
                my ($var, $exp) = @x;
                if $var ~~ Positional {
                    $.scope{$var[0]} =
                    self.evaluate-tokens([ Symbol('Ī»'), [ $var[1..*] ], $exp]);
                }
                else { $.scope{$var}  =self.evaluate-tokens($exp); }
            }
            when 'lambda' | 'Ī»' {
                my ($vars, $exp) = @x;
                Func.new( code => -> *@argv {
                    my %x = flat ($vars.list Z @argv);
                    my $new-env = Env.new(scope => %x , outer => self);
                    $new-env.evaluate-tokens($exp)
                },
                desc => "closure:arity:{$vars.elems}" );
            }
            when 'begin'   {
                my $val;
                fail "syntax error" unless +@x;
                for @x -> $exp {
                    $val = self.evaluate-tokens($exp);
                }
                $val;
            }
            default {
                my $func = self.evaluate-tokens($verb);
                my @args = map {
                    self.evaluate-tokens($^x)
                }, @x;
                fail "$verb is not a function" unless $func ~~ Func;
                $func.eval(@args)
            }

        }

    }
    multi method evaluate-tokens(Literal $x) {
        $x
    }
    multi method evaluate-tokens(Any $x) {
        fail $x.^name ~ " is NYI"
    }
    multi method add-builtin(*@x, *%x) {
        for |@x,|%x -> $p {
            $.scope{$p.key} = Func.new:
                            code => $p.value,
                            desc => "builtin:{$p.key}"
        }
    }
    method add-constant(*@x, *%x) {
        for |@x,|%x -> $p {
            $.scope{$p.key} = $p.value
        }
    }
}

our %*LISP-GLOBAL;

our $*LISP-ENV = Env.new(scope => %*LISP-GLOBAL);


$*LISP-ENV.add-constant:
    '#t' => True,
    '#f' => False
;

$*LISP-ENV.add-builtin:
     '>'       =>-> *@a { [>] @a },
     '<'       =>-> *@a { [<] @a },
     '>='      =>-> *@a { [>=] @a },
     '<='      =>-> *@a { [<=] @a },
     '='       =>-> *@a { [==] @a },
;

# ariphmetic ops
$*LISP-ENV.add-builtin:
     '+'       =>-> *@a { [+] @a },
     '-'       =>-> *@a { +@a > 1 ?? [-] @a !! - @a[0] },
     '*'       =>-> *@a { [*] @a },
     '/'       =>-> *@a { [/] @a },
     abs       =>   &abs,
;

# lisp ops
$*LISP-ENV.add-builtin:
     list    =>-> *@a { @a.item  },
     length  =>->  $a { $a.elems  },
     cons    =>-> *@a { @a.item   },
     car     =>->  @a { @a[0]     },
     cdr     =>->  @a { @a[1...*] },
     append  =>-> *@a {
         my @x =  @a[0][0..*];
         @x.push: @a[1];
         @x;
     },
     'list?'   =>-> *@a  { so @a[0] ~~ Positional },
     'null?'   =>-> *@a  { fail "too many arguments" unless +@a == 1 ;  @a[0].elems == 0 },
;

$*LISP-ENV.add-builtin:
  not     => -> $a { not $a },
  so      => -> $a { so  $a },
  'equal?'  => -> *@a { [~~] @a },
  'symbol?' => -> *@a {
    fail "NYI"
  },
  display => -> *@a {
    say join ', ', @a.map(*.Str);
  },
  exit    => -> $a { exit $a };


sub eval(Str $sexp) {
    $*LISP-ENV.evaluate-tokens(parse-sexp $sexp)
}

sub balanced($s) {
    my $l = 0;
    for $s.comb {
        when ")" {
            --$l;
            #return False if $l < 0;
        }
        when "(" {
            ++$l;
        }
    }
    $l ;
}

multi lispify(Positional $x) {
    '\'(' ~ @$x.map(*.&lispify).join(' ') ~ ')'
}
multi lispify(Bool $x where so * )  { '#t' }
multi lispify(Bool $x where not so * )  { '#f' }
multi lispify(Any $x) { $x.gist }

sub REPL {
    my Str $exp = '';
    my Int $balance = 0;
    loop {
        try {
            my $p =  prompt(
                $exp eq ''
                    ?? '> '
                    !! ('--' xx $balance) ~ '> '
            );
            exit unless defined $p;
            $exp ~= "$p ";
            $exp ~~ s:i/ ';' ** 1..* .*? $$//;
            $balance = balanced $exp;
            fail "unexpected bracket" if $balance < 0;
            next if $balance != 0 || $exp !~~ /\S+/;

            my $result = eval $exp;

            say ";; " ~ $result.&lispify;

            CATCH {
                default {
                    say "error: $_";
                }
            }
        }
        $exp = '';
    }
}

sub MAIN(Bool :$test     = False,
         Bool :$debug    = False,
         Str  :$file            ,
         Str  :$command         ,
         ) {
    if $command {
        return eval $command
    }

    if $file {
        die "Can't open '$file'" unless $file.IO.f;
        my $exp;
        for $file.IO.lines {
            my $line = $_;
            $line ~~ s:i/ ';' * 1..*  .*? $$ //;
            $exp ~= $line;
            if balanced($exp) == 0 {
                eval $exp;
                $exp = '';
            }
        }
        return;
    }

    return TEST  if $test;
    return DEBUG if $debug;

    REPL
}

sub DEBUG {
    ...
}

sub TEST {
    use Test;

    ok so parse-sexp("1"), "number";

    ok so parse-sexp("#t"), "true";
    ok so parse-sexp("#f"), "false";
    ok so parse-sexp("(- 1 2 3)"), "simple s-exp";
    ok so parse-sexp("(+ 1 2 3 (* 1 2 3))"), "nested s-exps";

    is-deeply parse-sexp('1'), 1, "parse atom (numeric)";

    is-deeply parse-sexp('#f'), Symbol('#f'),  "parse atom (boolean)";
    is-deeply parse-sexp('var'), Symbol('var'),  "parse atom (variable)";

    ok parse-sexp("(1 2 3 4 5)") == ["1", "2","3","4","5"], "sexp";
    ok parse-sexp("(1 2 3 (4 5 6))")  == ["1", "2", "3", ["4", "5", "6"]], "nested sexps";

    {
        my $y =  [Symbol('+'), 1, 2, 3];
        is-deeply parse-sexp('(+ 1 2 3)'), $y , "s-exp";
        is-deeply parse-sexp('   (+    1   2    3 )'), $y, "spaces are irrelevant";
    }

    {
        my $y = [Symbol('foo'), 1, [Symbol('quote'), [1, 2, 3]]];
        is-deeply parse-sexp("(foo 1 '(1 2 3))"),
        $y,
        "quote by symbol";
        is-deeply parse-sexp("(foo 1 (quote (1 2 3)))"), $y, "quote by word";
    }
    #

    ok !eval("(not #t)"), "booleans";
    ok eval("(not #f)") , "booleans";
    ok !eval("(so #f)") , "booleans";
    ok  eval("(so #t)") , "booleans";

    ok eval("(+ 1 2 3)") == 6, 'sum';
    ok eval("(* 1 2 5)") == 10, 'product';
    ok eval("(cons 1 2)") == ['1','2'], 'cons';
    ok eval("(append (cons 1 2) 1)") == [<1 2 1>], 'append';
    ok eval("(list 1 2 3 4)") == [1,2,3,4], "list";
    ok eval("(car (list 1 2 3 4))") == 1 ,"car";
    ok eval("(cdr (list 1 2 3 4))") == [2,3,4] ,"cdr";
    ok eval("(list? (list 1 2 3 4))") ,"list?";
    ok !eval("(list? #f)") ,"list?";
    ok eval("(null? (list))") ,"null? on empty list";
    ok eval("(null? '())") , 'null? on `() ';
    ok !eval("(null? '(1 2 3))") , 'null?';
    ok eval("(equal? 1 1)") ,"equal?";
    ok !eval("(equal? 1 0)") ,"equal?";

    {
        ok eval("(define xxx 1)") == 1 ,"define";
         eval("(set! xxx 2)");
        ok eval("xxx") == 2, 'set!';
    }

    ok eval("(define xs (list 1 2 3 4))") == [[1,2,3,4]] ,"define";
    ok eval("(define sqr (lambda (x) (* x x)))") , 'define'; ;
    is eval("(length xs)"), 4, 'length';
    is eval("((lambda (x) (* x x)) 13)"), 169, 'lambda';
    is eval("(sqr 10)"), 100, 'lambda';
    ok eval("(define plus (lambda (x y) (+ x y)))") && eval("(plus 1 2)") == 3, "lambda";
    ok eval("(if (> 1 2) 3 4)") == 4, 'if';
    ok eval("(if (< 1 2) 3 4)") == 3, 'if';
    ok eval("(abs 3)") == 3, 'abs';
    ok eval("(abs (- 3))") == 3, 'abs';

    ok eval("(begin 1 2 3 4 5)") == 5, 'begin';
    ok eval("(quote (1 2 3 4 5))") == [<1 2 3 4 5>], 'quote';
    ok eval("(quote (1))") == ['1',], 'quote';

    ok eval("(eval (quote 1))") == 1 , 'eval';
    ok eval("(eval '(+ 1 2 3))") == 6 , 'eval';
    ok (
        eval "(list 1 (list 2 (list 3 (list 3 5))))" ) ==
                [["1", ["2", ["3", ["3", "5"]]]]], 'nested list';
    ok eval(qq{ (define fib (lambda (n)  (if (< n 2)  1  (+ (fib (- n 1)) (fib (- n 2)))))) })  &&
    eval("(fib 10)") == 89, 'fib(10)';
    eval '
         (define (sqrt x)
           (begin
            (define (square x) (* x x))
            (define (average x y) (/ (+ x y) 2))
            (define (good-enough? guess x)
              (< (abs (- (square guess) x)) 0.001))
            (define (improve guess)
              (average guess (/ x guess)))
            (define (sqrt-iter guess)
              (if (good-enough? guess)
                  guess
                (sqrt-iter (improve guess))))
            (sqrt-iter 1.0)))
    ';
    ok eval("(sqrt 4)").Int == 2, 'sqrt example';

    done-testing;
}

# vim: expandtab shiftwidth=4 ft=perl6

See Also

brainfuck.p6

Brainfuck Interpreter

calc.p6

Simple Infix Arithmetic Calculator

RPN.pl

Reverse Polish Notation Calculator

The Camelia image is copyright 2009 by Larry Wall. "Raku" is trademark of the Yet Another Society. All rights reserved.