rubylisp 0.1.0

data/lib/rubylisp/environment_frame.rb

@@ -0,0 +1,116 @@
+module Lisp
+
+  class EnvironmentFrame
+
+    attr_accessor :frame
+    
+    def self.global
+      @@global_frame ||= EnvironmentFrame.new(nil)
+      @@global_frame
+    end
+
+    def self.extending(parent, f=nil)
+      f ||= parent.frame if parent && parent.has_frame?
+      self.new(parent, f)
+    end
+
+    def initialize(parent, f=nil)
+      @bindings = []
+      @parent = parent
+      @frame = f
+    end
+
+    def has_frame?
+      !@frame.nil?
+    end
+    
+    # Bindings following parent env frame pointer
+
+    def is_name_bound?(str)
+      if !@frame && @frame.has_slot?(Lisp:Symbol.named("#{str}:", true))
+        return true
+      end
+        
+      binding = @bindings.detect {|b| b.symbol.name == str}
+      return true unless binding.nil?
+      return false if @parent.nil?
+      return @parent.is_name_bound?(str)
+    end
+
+    def binding_for(symbol)
+      binding = @bindings.detect {|b| b.symbol.name == symbol.name}
+      return binding unless binding.nil?
+      return @parent.binding_for(symbol) unless @parent.nil?
+      nil
+    end
+
+    def bind(symbol, value)
+      b = self.binding_for(symbol)
+      if b.nil?
+        @bindings << Lisp::Binding.new(symbol, value)
+      else
+        b.value = value
+      end
+    end
+
+    def set(symbol, value)
+      naked_symbol = symbol.to_naked
+      if @frame && @frame.has_slot?(naked_symbol)
+        return @frame.at_put(naked_symbol, value)
+      end
+        
+      b = self.binding_for(symbol)
+      if b.nil?
+        raise "#{symbol} is undefined."
+      else
+        b.value = value
+      end
+    end
+
+    # Bindings local to this env frame only
+
+    def local_binding_for(symbol)
+      @bindings.detect {|b| b.symbol.name == symbol.name}
+    end
+
+    def bind_locally(symbol, value)
+      b = self.local_binding_for(symbol)
+      if b.nil?
+        @bindings << Lisp::Binding.new(symbol, value)
+      else
+        b.value = value
+      end
+    end
+
+    # Look up a symbol
+
+    def value_of(symbol)
+      b = local_binding_for(symbol)
+      return b.value unless b.nil?
+                
+      naked_symbol = symbol.to_naked
+      if @frame && @frame.has_slot?(naked_symbol)
+        return @frame.get(naked_symbol)
+      end
+
+      b = binding_for(symbol)
+      return b.value unless b.nil?
+      nil
+    end
+    
+
+    def quick_value_of(symbol_name)
+      b = binding_for(Symbol.new(symbol_name))
+      b.nil? ? nil : b.value
+    end
+    
+
+    def dump
+      @bindings.each do |b|
+        puts b.to_s
+      end
+    end
+
+  end
+
+end

data/lib/rubylisp/equivalence.rb

@@ -0,0 +1,118 @@
+module Lisp
+
+  class Equivalence
+
+    def self.register
+      Primitive.register("=", "(= number number)\n\nReturns whether the first numeric argument is equal to the second numeric argument.") do |args, env|
+        Lisp::Equivalence::num_eq_impl(args, env)
+      end
+      
+      Primitive.register("==", "(== number number)\n\nReturns whether the first numeric argument is equal to the second numeric argument.") do |args, env|
+        Lisp::Equivalence::num_eq_impl(args, env)
+      end
+      
+      Primitive.register("!=", "(!= number number)\n\nReturns whether the first numeric argument is not equal to the second numeric argument.") do |args, env|
+        Lisp::Equivalence::num_neq_impl(args, env)
+      end
+      
+      Primitive.register("/=", "(/= number number)\n\nReturns whether the first numeric argument is not equal to the second numeric argument.") do |args, env|
+        Lisp::Equivalence::num_neq_impl(args, env)
+      end
+
+      Primitive.register("eq?", "(eq? sexpr sexpr)\n\nReturns whether the first argument is the same type as the second argument, and the same object, except in the case of numbers where the values are compared.") do |args, env|
+        Lisp::Equivalence::eq_impl(args, env)
+      end
+      
+      Primitive.register("eqv?", "(eqv? sexpr sexpr)\n\nReturns whether the first argument is the same type as the second argument, and the same object, except in the case of numbers where the values are compared.") do |args, env|
+        Lisp::Equivalence::eqv_impl(args, env)
+      end
+      
+      Primitive.register("equal?", "(equal? sexpr sexpr)\n\nReturns whether the first argument is the same type as the second argument, and are lists containing the same elements, are identical strings, are frames with matching slots, are numbers with the same value, or are the same object (if none of the above).") do |args, env|
+        Lisp::Equivalence::equal_impl(args, env)
+      end
+      
+    end
+
+    # == - Check two integers for equivalence
+    
+    def self.num_eq_impl(args, env)
+      raise "= and == need 2 arguments, received #{args.length}" if args.length != 2
+      c1 = args.car.evaluate(env)
+      c2 = args.cadr.evaluate(env)
+      return Lisp::FALSE unless c1.integer? && c2.integer?
+      Lisp::Boolean.with_value(c1.value == c2.value)
+    end
+
+    def self.num_neq_impl(args, env)
+      raise "!= and /= needs 2 arguments, received #{args.length}" if args.length != 2
+      c1 = args.car.evaluate(env)
+      c2 = args.cadr.evaluate(env)
+      return Lisp::TRUE unless c1.integer? && c2.integer?
+      Lisp::Boolean.with_value(c1.value != c2.value)
+    end
+
+
+    # eq? - identity, typically used for symbols
+    
+    def self.eq_check(o1, o2)
+      return Lisp::FALSE unless o1.type == o2.type
+      Lisp::Boolean.with_value(case o1.type
+                               when :number
+                                 (o1.integer? == o2.integer?) && (o1.value == o2.value)
+                               else
+                                 o1.equal?(o2)
+                               end)
+    end
+    
+
+    def self.eq_impl(args, env)
+      raise "eq? needs 2 arguments, received #{args.length}" if args.length != 2
+      o1 = args.car.evaluate(env)
+      o2 = args.cadr.evaluate(env)
+      eq_check(o1, o2)
+    end
+    
+
+    # eqv? - same as eq?
+
+    def self.eqv_check(o1, o2)
+      eq_check(o1, o2)
+    end
+    
+    
+    def self.eqv_impl(args, env)
+      raise "eq? needs 2 arguments, received #{args.length}" if args.length != 2
+      o1 = args.car.evaluate(env)
+      o2 = args.cadr.evaluate(env)
+      eqv_check(o1, o2)
+    end
+    
+
+    # equal? - object equality: same value
+
+    def self.equal_check(o1, o2)
+      return Lisp::FALSE unless o1.type == o2.type
+      Lisp::Boolean.with_value(case o1.type
+                               when :pair
+                                 o1.eq?(o2)
+                               when :string
+                                 o1.value.eql?(o2.value)
+                               when :frame
+                                 o1.eq?(o2)
+                               when :number
+                                 (o1.integer? == o2.integer?) && (o1.value == o2.value)
+                               else
+                                 o1.equal?(o2)
+                               end)
+    end
+
+    
+    def self.equal_impl(args, env)
+      raise "equal? needs 2 arguments, received #{args.length}" if args.length != 2
+      o1 = args.car.evaluate(env)
+      o2 = args.cadr.evaluate(env)
+      self.equal_check(o1, o2)
+    end
+  end
+
+end

data/lib/rubylisp/exception.rb

@@ -0,0 +1,98 @@
+module Lisp
+
+  class Exception
+
+    def self.register
+      Primitive.register("raise")     {|args, env| Lisp::Exception::raise_impl(args, env) }
+      Primitive.register("reraise")   {|args, env| Lisp::Exception::reraise_impl(args, env) }
+      Primitive.register("try")       {|args, env| Lisp::Exception::try_impl(args, env) }
+      Primitive.register("reraise")   {|args, env| Lisp::Exception::reraise_impl(args, env) }
+      Primitive.register("resume")    {|args, env| Lisp::Exception::resume_impl(args, env) }
+      Primitive.register("restart")   {|args, env| Lisp::Exception::restart_impl(args, env) }
+    end
+
+
+    def handler_or_nil(handlers, exception_name)
+      handlers.each do |handler_pair|
+        exceptions = handler_pair.car
+        if exceptions.eq(exception_name) || (exceptions.pair? && exceptions.include?(exception_name))
+          handler_pair.cdr
+        else
+          nil
+        end
+      end
+    end
+
+    def self.do_exception(name, with_message, args, env)
+      frame = env
+      while !frame.nil?
+        handlers = frame.value_of(Symbol.named("__handlers__"))
+        unless handlers.nil?
+          handler = handler_or_nil(handlers, for: name)
+          unless handler.nil?
+            handler.apply_to_without_evaluating(args, in: frame)
+            break
+          end
+        end
+        frame = frame.parent
+        if frame.nil?
+          exception_message = message.empty? ? "" : ": #{message}"
+          raise "Unhandled Exception: #{exception_name}#{exception_message}"
+        end
+      end
+    end
+    
+    def self.raise_impl(args, env)
+      raise "'raise' requires at least one argument." unless args.length > 0
+      exception_name = args.car.evaluate(env)
+      raise "'raise' requires an exception name as it's first argument." unless exception_name.string? || class_name.symbol?
+
+      message = ""
+      if args.length > 1
+        message = args.cadr.evaluate(env)
+        raise "The message parameter to 'raise' must be a string." unless message.string?
+      end
+
+      handler_args = args.length > 2 ? Lisp::ConsCell.array_to_list(args.cdr.to_a.collect {|a| a.evaluate(env)}) : Lisp::ConsCell.new
+    end
+  
+
+    def self.try_impl(args, env)
+      raw_handlers = args.car
+      body = args.cdr
+      
+      raise "Exception handlers must be a list." unless raw_handlers.list?
+      raise "Exception handlers must be a list of pairs." unless raw_handlers.all? {|h| h.list?}
+      raise "Exception clause must be a symbol/string or a list of symbol/string." unless raw_handlers.all? do |h|
+        ex = h.car
+        ex.symbol? || ex.string? || (ex.list? && ex.all? {|h2| h2.symbol? || h2.string?})
+      end
+      
+      array_of_handlers = raw_handlers.to_a.collect do |h|
+        ex = h.car
+        f = h.cadr.evaluate(env)
+      raise "Exception handler has to be a function." unless f.function?
+        Lisp::ConsCell.cons(ex, f)
+      end
+      handlers = Lisp::ConsCell.array_to_list(array_of_handlers)
+      env.bind_locally(Symbol.named("__handlers__"), handlers)
+      
+      body.evaluate_each(env)
+    end
+
+
+    def self.reraise_impl(args, env)
+    end
+
+
+    def self.resume_impl(args, env)
+    end
+
+
+    def self.restart_impl(args, env)
+    end
+
+    
+  end
+end
+

data/lib/rubylisp/ext.rb

@@ -0,0 +1,122 @@
+class NilClass
+
+  def true?
+    false
+  end
+  
+  def false?
+    true
+  end
+
+  def to_s
+    "()"
+  end
+
+  def eq?(other)
+    other.nil?
+  end
+  
+  def print_string
+    self.to_s
+  end
+
+  def evaluate(env)
+    nil
+  end
+
+  def evaluate_each(env)
+    nil
+  end
+
+  def car
+    nil
+  end
+
+  def cdr
+    nil
+  end
+
+  def set_car!(s)
+    nil
+  end
+  
+  def set_cdr!(s)
+    nil
+  end
+
+  def quoted
+    nil
+  end
+  
+  def empty?
+    true
+  end
+
+  def length
+    0
+  end
+  
+  def value
+    nil
+  end
+
+  def string?
+    false
+  end
+  
+  def number?
+    false
+  end
+  
+  def symbol?
+    false
+  end
+  
+  def pair?
+    false
+  end
+  
+  def list?
+    true
+  end
+  
+  def method_missing(name, *args, &block)
+    if name[0] == ?c && name[-1] == ?r && (name[1..-2].chars.all? {|e| "ad".include?(e)})
+      nil
+    else
+      super
+    end
+  end
+
+  def primitive?
+    false
+  end
+  
+  def function?
+    false
+  end
+
+  def object?
+    false
+  end
+
+  def type
+    :nil
+  end
+
+  def lisp_object?
+    true
+  end
+    
+
+  
+end
+
+
+class Object
+
+  def lisp_onject?
+    false
+  end
+    
+end

data/lib/rubylisp/ffi_class.rb

@@ -0,0 +1,162 @@
+# -*- coding: utf-8 -*-
+module Lisp
+
+  class ClassObject < Atom
+
+    def self.register
+      Primitive.register("extend", "(extend parent child)\n\nCreates a new class named child that extends (i.e. inherits from) the class parent. The names (parent and child can be either stirngs or symbols). The new class is accessible by name and is returned.") do |args, env|
+        Lisp::ClassObject::extend_impl(args, env)
+      end
+      
+      Primitive.register("add-method", "(add-method class selector function)\n\nAdd a method named selector to the class named class using function as it’s body. function can be a reference to a named function or, more likely, a lambda expression.") do |args, env|
+        Lisp::ClassObject::add_method_impl(args, env)
+      end
+      
+      Primitive.register("add-static-method", "Not Implemented.") do |args, env|
+        Lisp::ClassObject::add_static_method_impl(args, env)
+      end
+      
+      Primitive.register("super", "Not implemented.") do |args, env|
+        Lisp::ClassObject::super_impl(args, env)
+      end
+      
+    end
+
+
+    def self.extend_impl(args, env)
+      raise "'extend' requires 2 arguments." if args.length != 2
+
+      class_name = args.car.evaluate(env)
+      raise "'extend' requires a name as it's first argument." unless class_name.string? || class_name.symbol?
+      super_class = Object.const_get(class_name.to_s)
+      raise "'extend' requires the name of an existing class as it's first argument." if super_class.nil?
+
+      new_class_name = args.cadr.evaluate(env)
+      raise "'extend' requires a name  as it's second argument." unless new_class_name.string? || new_class_name.symbol?
+      new_class = Class.new(super_class)
+      raise "'extend' requires the name of a new (i.e. nonexistant) class as it's second argument." if Object.const_defined?(new_class_name.to_s)
+
+      Object.const_set(new_class_name.to_s, new_class)
+      ClassObject.with_class(new_class)
+    end
+
+    
+    def self.convert_to_lisp(value)
+      case value.class.name
+      when "Fixnum", "Float"
+        Lisp::Number.with_value(value)
+      when "TrueClass"
+        Lisp::Boolean.TRUE
+      when "FalseClass"
+        Lisp::Boolean.FALSE
+      when "String"
+        Lisp::String.with_value(value)
+      when "Symbol"
+        Lisp::Symbol.named(value)
+      when "Array"
+        Lisp::ConsCell.array_to_list(value.map {|a| convert_to_lisp(a)})
+      else
+        value.lisp_object? ? value : Lisp::NativeObject.with_value(value)
+      end
+    end
+
+    
+    def self.convert_to_ruby(a, env)
+      if a.nil?
+        nil
+      elsif a.function?
+        proc do 
+          a.apply_to(Lisp::ConsCell.new, env)
+        end
+      elsif a.list?
+        a.to_a.map {|i| convert_to_ruby(i, env)}
+      else
+        a.value
+      end
+    end
+
+    
+    def self.add_method_impl(args, env)
+      raise "'add-method' requires 3 arguments." if args.length != 3
+      class_name = args.car.evaluate(env)
+      raise "'add-method' requires a class name as it's first argument." unless class_name.string? || class_name.symbol?
+      target_class = Object.const_get(class_name.to_s)
+      raise "'add-method' requires the name of an existing class." if target_class.nil?
+
+      method_name = args.cadr.evaluate(env)
+      raise "'add-method' requires a method name as it's second argument." unless class_name.string? || class_name.symbol?
+
+      body = args.caddr.evaluate(env)
+      raise "'add-method' requires a function as it's third argument." unless body.function?
+      
+      target_class.send(:define_method, method_name.to_s) do |*args|
+        local_env = Lisp::EnvironmentFrame.extending(env)
+        local_env.bind_locally(Symbol.named("self"), Lisp::NativeObject.with_value(self))
+        processed_args = args.map {|a| Lisp::ClassObject.convert_to_lisp(a)}
+        Lisp::ClassObject.convert_to_ruby(body.apply_to(Lisp::ConsCell.array_to_list(processed_args), in: local_env), in: local_env)
+      end
+      Lisp::String.with_value("OK")
+    end
+
+
+    def self.super_impl(args, env)
+      Lisp::String.with_value("NOT IMPLEMENTED")
+    end
+
+    
+    def self.add_static_method_impl(args, env)
+      Lisp::String.with_value("NOT IMPLEMENTED")
+    end
+
+
+    def self.new_instance
+      self.new(@value.alloc.init)
+    end
+
+
+    def self.with_class(c)
+      self.new(c)
+    end
+
+    
+    def initialize(c)
+      @value = c
+    end
+
+    
+    def with_value(&block)
+      block.call(@value)
+    end
+
+    
+    def class?
+      true
+    end
+
+    
+    def type
+      :class
+    end
+
+    
+    def native_type
+      @value.class
+    end
+
+    
+    def to_s
+      "<a class: #{@value.name}>"
+    end
+
+    
+    def true?
+      @value != nil
+    end
+
+    
+    def false?
+      @value == nil
+    end
+
+  end
+end

data/lib/rubylisp/ffi_new.rb

@@ -0,0 +1,32 @@
+module Lisp
+
+  class FfiNew < Atom
+
+    def initialize(name)
+      @value = name
+      @klass = Object.const_get(name)
+    end
+
+    def apply_to(args, env)
+      NativeObject.with_value(@klass.new)
+    end
+
+    def apply_to_without_evaluating(args, env)
+      NativeObject.with_value(@klass.new)
+    end
+
+    def to_s
+      "#{@value}."
+    end
+
+    def primitive?
+      true
+    end
+
+    def type
+      :primitive
+    end
+
+  end
+
+end