The LISP expressed with Ruby

lisp.rb

# lisp.rb - The LISP expressed with Ruby
#
#   * Program code can be written in Ruby's data structures (Array, Symbol, ...)
#   * LISP-2 (http://en.wikipedia.org/wiki/Lisp-1_vs._Lisp-2#The_function_namespace)
#
# "THE ROOTS OF LISP" by Paul Graham
# http://www.paulgraham.com/rootsoflisp.html
#

require 'strscan'

class SexpParser

    EXTENDED_ALPHA_CHARS = '!$%&*+\-./:<=>?@^_~';
    IDENT_PATTERN = '[a-z' + Regexp.quote(EXTENDED_ALPHA_CHARS) + ']' +
                    '[a-z' + Regexp.quote(EXTENDED_ALPHA_CHARS) + '0-9]*'
    IDENT_REGEXP = Regexp.compile(IDENT_PATTERN, Regexp::IGNORECASE)

    def initialize(src)
        @scanner = StringScanner.new(src)
    end

    attr_reader :scanner

    include Enumerable

    def each
        while expr = parse_expr
            yield expr
        end
    end

    def parse_expr
        sexp = [[]]

        until scanner.eos?
            next if scanner.skip(/\s+/m)
            next if scanner.skip(/;.*/)

            if scanner.scan(/\(/)
                lst = []
                sexp[-1].push(lst)
                sexp.push(lst)
            elsif scanner.scan(/\)/)
                if sexp.size <= 1
                    raise 'Unmatched right paren found'
                end
                sexp.pop()
            elsif scanner.scan(IDENT_REGEXP)
                symbol = scanner[0].to_sym
                sexp[-1].push(scanner[0].to_sym)
            elsif scanner.scan(/[0-9]+(\.[0-9]+)?/)
                num = scanner[1] ? scanner[0].to_f
                                 : scanner[0].to_i
                sexp[-1].push(num)
            elsif scanner.scan(/(")(.*?)\1/m)
                sexp[-1].push(scanner[2])
            elsif scanner.scan(/'/)
                # reader macro: quote
                expr = [:quote, parse_expr()]
                sexp[-1].push(expr)
            else
                raise 'Unrecognized tokens found: ' + scanner.rest[0..10]
            end

            break if sexp.size == 1
        end

        if sexp.size != 1
            raise 'Unmatched left paren found'
        end

        return sexp[0][0]
    end

    def parse
        return self.take_while { |expr| expr }
    end

end


class Environment

    class NilEnvironment
        def [](sym);  end
    end

    def initialize(vars={}, parent=NilEnvironment.new)
        @parent = parent
        @bindings = vars.clone
    end

    def [](sym)
        (@bindings.has_key?(sym) ? @bindings : @parent)[sym]
    end

    def define(sym, value)
        @bindings[sym] = value
    end

end

class Lazy

    def initialize(params=nil, &block)
        @params = params
        @block  = block
    end

    def parameters
        return @params || @block.parameters
    end

    def call(evaluator, args)
        evaluator.instance_exec(*args, &@block)
    end

end

class Eval < Lazy

    def call(evaluator, args)
        super( evaluator, args.map {|a| evaluator.evaluate(a) } )
    end

end

class Evaluator

    def initialize
        @frames = [ Environment.new(BUILTINS) ]
    end

    def top_env
        return @frames.first
    end

    def current_env
        return @frames[-1]
    end

    def push_env(vars)
        @frames.push(Environment.new(vars, current_env))
    end

    def pop_env
        @frames.pop
    end

    def with_scoped(vars={})
        push_env(vars)
        ret = yield
        pop_env
        ret
    end

    def define_top_level(sym, value)
        top_env.define(sym, value)
    end

    def evaluate(expr)
        value = nil

        case expr
        when Symbol
            value = self.current_env[expr]
            raise %Q|Unable to resolve symbol: "#{expr}"| if value.nil?
        when Array
            operator, *arguments = expr
            value = self.evaluate(operator).call(self, arguments)
        else
            value = expr
        end

        return [] if value.nil?
        return :t if value.is_a?(TrueClass)
        value
    end

    def true_value?(value)
        !!value && !(value.is_a?(Array) && value.empty?)
    end

end


BUILTINS = {
    :list?  => Eval.new {|x| x.is_a?(Array) && x.size > 0 },
    :equal? => Eval.new {|x,y| x == y },
    :car    => Eval.new {|x| x.first },
    :cdr    => Eval.new {|x| x.drop(1) },
    :cons   => Eval.new {|x,y| [x, *y] },
    :quote  => Lazy.new {|x| x },
    :cond   => Lazy.new {|*lst|
        _, expr = lst.find {|cond, expr| self.true_value?(self.evaluate(cond)) }
        self.evaluate(expr)
    },

    :+ => Eval.new {|*n| n.reduce(&:+) },
    :- => Eval.new {|*n| n.reduce(&:-) },
    :* => Eval.new {|*n| n.reduce(&:*) },
    :/ => Eval.new {|*n| n.reduce(&:/) },

    :assert => Lazy.new {|expr|
        self.evaluate(expr).tap do |value|
            unless self.true_value?(value)
                raise "Assertion failed: #{expr}"
            end
        end
    },

    :lambda => Lazy.new {|params, expr|
        raise "empty function body" if expr.nil? || expr.empty?

        Eval.new(params.clone) {|*args|
            if args.size != params.size
                raise "wrong number of arguments (#{args.size} for #{params.size})"
            end

            vars = params.zip(args).inject({}) {|h, v| h.update(v[0] => v[1]) }
            self.with_scoped(vars) do
                self.evaluate(expr)
            end
        }
    },
    :define => Lazy.new {|*args|
        raise "define: missing name" if args.empty?
        raise "wrong number of arguments (#{args.size} for 2)" if args.size != 2

        name, expr = args
        if name.is_a?(Array)
            # If the `name` is an Array instance, which indicates that
            # this is a procedure definition.
            name, *args = name
            expr = [:lambda, args, expr]
        end
        self.define_top_level(name, self.evaluate(expr))
    },
}


def evaluate(expr)
    Evaluator.new.evaluate(expr)
end

def evaluate_source(src, evaluator=nil)
    evaluator ||= Evaluator.new
    program = SexpParser.new.parse(src)
    (program.map {|expr| evaluator.evaluate(expr) })[-1]
end

lisp_spec.rb

require 'lisp'


describe Evaluator, "#evaluate" do
    it "evaluates S-expression expressed with Ruby Array" do
        evaluator = Evaluator.new

        expr = 
            [:cond,
                [[:equal?, [:quote, :a], [:quote, :b]], [:quote, :first]],
                [[:list?,  [:quote, [:a, :b]]],         [:quote, :second]]]
        evaluator.evaluate(expr).should == :second
        
        expr = 
            [[:lambda, [:f], [:f, [:quote, [:b, :c]]]],
                [:lambda, [:x], [:cons, [:quote, :a], :x]]]
        evaluator.evaluate(expr).should == [:a, :b, :c]

        evaluator.evaluate([:define, :x, 1234])
        evaluator.evaluate(:x).should == 1234

        evaluator.evaluate([:define, [:double, :x], [:*, :x, 2]])
        evaluator.evaluate([:double, 23]).should == 46
    end

    it "resolve boolean variables" do
        evaluator = Evaluator.new
        evaluator.evaluate([:define, :x, 123])
        evaluator.current_env[:x].should == 123
        evaluator.evaluate(:x).should == 123

        evaluator.evaluate([:define, :b, false])
        evaluator.current_env[:b].should == false
        evaluator.evaluate(:b).should == false
    end

    it "passes array arguments (lambda)" do
        evaluator = Evaluator.new

        expr = [[:lambda, [:x, :y], [:cons, [:car, :x], :y]],
                    [:quote, [1, 2, 3]],
                    [:quote, [4, 5, 6]]]
        evaluator.evaluate(expr).should == [1, 4, 5, 6]
    end

    it "passes array arguments (define)" do
        evaluator = Evaluator.new

        expr = [:define, [:f, :x, :y], [:cons, [:car, :x], :y]]
        fn = evaluator.evaluate(expr)
        fn.parameters.should == [:x, :y]
        fn.should respond_to :call

        expr = [:f, [:quote, [1, 2, 3]],
                    [:quote, [4, 5, 6]]]
        evaluator.evaluate(expr).should == [1, 4, 5, 6]
    end

end

describe SexpParser, "#parse" do

    it "returns empty list when parsing blank string" do
        SexpParser.new('   ').parse.should == []
    end

    it "ignores comments" do
        SexpParser.new(';').parse.should == []
        SexpParser.new('; This is a comment').parse.should == []
        SexpParser.new("; This is a comment\n'(1 2 3)").parse.should == [[:quote, [1, 2, 3]]]
    end

    it "parses a S-expression" do
        parser = SexpParser.new('(define (double x) (* x 2))')
        sexp = parser.parse
        sexp.should == [[:define, [:double, :x], [:*, :x, 2]]]
    end

    it "parses S-expressions" do
        parser = SexpParser.new('
                (define (double x) (* x 2))
                (define x 123)
                (double x)')
        sexp = parser.parse
        sexp.should == [
            [:define, [:double, :x], [:*, :x, 2]],
            [:define, :x, 123],
            [:double, :x],
        ]
    end

    it "parses string" do
        SexpParser.new('"string"').parse_expr.should == "string"
    end

    it "parses reader macro 'quote'" do
        {
            "'(1 2 3)" => [:quote, [1, 2, 3]],
            "'()" => [:quote, []],
        }.each do |src, expected|
            expr = SexpParser.new(src).parse_expr
            expr.should == expected
        end
    end

    it "recognizes unmatched parens" do
        lambda { SexpParser.new('(').parse }.should raise_exception
        lambda { SexpParser.new(')').parse }.should raise_exception
        lambda { SexpParser.new('(define x 1))))').parse }.should raise_exception
    end
end

describe Environment, "#[]" do
    it "returns nothing when initialized" do
        env = Environment.new
        env[:bowling].should be_nil
    end
end

describe Environment, "#define" do
    it "defines new entry" do
        env = Environment.new
        env.define(:score, 123)
        env[:score].should == 123
    end
end

sample_eval.scm

; 'eval' - A function that acts as an interpreter for out language.
;
;   "THE ROOTS OF LISP" by Paul Graham
;   http://www.paulgraham.com/rootsoflisp.html
;

(define (cadr e)  (car (cdr e)))
(define (caddr e) (car (cdr (cdr e))))
(define (cdar e)  (cdr (car e)))
(define (caar e)  (car (car e)))
(define (cadar e) (car (cdr (car e))))
(define (caddar e) (car (cdr (cdr (car e)))))

(define (null? x) (equal? x '()))
(define (and x y)
  (cond (x (cond (y 't) ('t '())))
        ('t '())))
(define (not x) (cond (x '())
                      ('t 't)))
(define (atom? x) (not (list? x)))

(define (append x y)
  (cond ((null? x) y)
        ('t (cons (car x) (append (cdr x) y)))))

(define (pair x y)
  (cond ((and (null? x) (null? y)) '())
        ((and (list? x) (list? y))
         (cons (cons (car x) (cons (car y) '()))
               (pair (cdr x) (cdr y))))))

(define (assoc x y)
  (cond ((null? y) '())
        ((equal? (caar y) x) (cadar y))
        ('t (assoc x (cdr y)))))


(assert (equal? (cons 1 (quote (2 3))) '(1 2 3)))
(assert (equal? (cadr '(1 2 3)) 2))
(assert (equal? (cdar '((a b) (c d) e)) '(b)))
(assert (null? '()))
(assert (and (list? '(a)) (equal? 'a 'a)))
(assert (equal? (append '(a b) '(c d)) '(a b c d)))
(assert (not '()))
(assert (equal? (pair '(1 2 3) '(4 5 6)) '((1 4) (2 5) (3 6))))
(assert (equal? (cadar '((a b) (c d) e)) 'b))
(assert (equal? (assoc 'x '((x a) (y b))) 'a))
(assert (null? (assoc 'a '())))


(define (eval. e a)
  (cond
    ((atom? e) (assoc e a))
    ((atom? (car e))
     (cond
       ((null?  (car e))        '())
       ((equal? (car e) 'quote) (cadr e))
       ((equal? (car e) 'atom)  (atom?  (eval. (cadr e) a)))
       ((equal? (car e) 'eq)    (equal? (eval. (cadr e) a)
                                        (eval. (caddr e) a)))
       ((equal? (car e) 'car)   (car    (eval. (cadr e) a)))
       ((equal? (car e) 'cdr)   (cdr    (eval. (cadr e) a)))
       ((equal? (car e) 'cons)  (cons   (eval. (cadr e) a)
                                        (eval. (caddr e) a)))
       ((equal? (car e) 'cond)  (evcon. (cdr e) a))
       ('t (eval. (cons (assoc (car e) a)
                        (cdr e))
                  a))))
    ((equal? (caar e) 'lambda)
      (eval. (caddar e)
             (append (pair (cadar e) (evlis. (cdr e) a))
                     a)))))

(define (evcon. c a)
  (cond ((null? c) '())
        ((eval. (caar c) a)
         (eval. (cadar c) a))
        ('t (evcon. (cdr c) a))))

(define (evlis. m a)
  (cond ((null? m) '())
        ('t (cons (eval. (car m) a)
            (evlis. (cdr m) a)))))


(assert (equal? (eval. '(quote a) '()) 'a))
(assert (eval. '(eq 1 1) '()))
(assert (equal? (eval. '(car (quote (1 2 3))) '()) 1))
(assert (equal? (eval. '(cdr (quote (1 2 3))) '()) '(2 3)))
(assert (equal? (eval. '(cons x (quote (b c))) '((x a) (y b))) '(a b c)))
(assert (equal? (eval. '(cond ((atom a) (quote b))) '((a 123))) 'b))
(assert (null? (eval. '(cond ('() 111)) '())))

(assert (equal? 
    (eval. '((lambda (x) (cons (quote a) x)) (quote (b c)))
           '())
    '(a b c)))

scm.rb

# Scheme interpreter
require "lisp"

evaluator = Evaluator.new
values = SexpParser.new(ARGF.read).map do |e|
    evaluator.evaluate(e)
end

p values[-1]