rubylisp 0.1.0

data/lib/rubylisp/symbol.rb

@@ -0,0 +1,56 @@
+module Lisp
+
+  class Symbol < Atom
+
+    def self.named(n)
+      name = n.to_s
+      @@symbols ||= {}
+      return @@symbols[n] if @@symbols.has_key?(n)
+      s = self.new(n)
+      @@symbols[n] = s
+      s
+    end
+
+    def initialize(n)
+      @value = n
+      @naked = (n[-1] == ?:)
+    end
+
+    def to_naked
+      Lisp::Symbol.named("#{@value}:")
+    end
+
+    
+    def name
+      @value
+    end
+
+    def symbol?
+      true
+    end
+
+    def naked?
+      @naked
+    end
+    
+
+    def type
+      :symbol
+    end
+
+    def evaluate(env)
+      return self if @naked
+      env.value_of(self)
+    end
+
+    def to_s
+      @value
+    end
+
+    def to_sym
+      @value.to_sym
+    end
+
+  end
+
+end

data/lib/rubylisp/system.rb

@@ -0,0 +1,19 @@
+module Lisp
+
+  class System
+
+    def self.register
+      Primitive.register("sleep")         {|args, env| Lisp::System.sleep_impl(args, env) }
+    end
+
+
+    def self.sleep_impl(args, env)
+      raise "sleep needs 1 argument" if args.length != 1
+      arg = args.car.evaluate(env)
+      raise "sleep needs a numeric argument" unless arg.number?
+      sleep(arg.value)
+    end
+
+    
+  end
+end

data/lib/rubylisp/testing.rb

@@ -0,0 +1,136 @@
+module Lisp
+
+  class Testing
+    
+
+    def self.register
+      Primitive.register("describe") {|args, env| Lisp::Testing::describe_impl(args, env) }
+      Primitive.register("check")    {|args, env| Lisp::Testing::check_impl(args, env) }
+      Primitive.register("check!")   {|args, env| Lisp::Testing::check_not_impl(args, env) }
+      Primitive.register("check*")   {|args, env| Lisp::Testing::check_star_impl(args, env) }
+    end
+
+    def self.describe_impl(args, env)
+      raise "First arg to describe must be a string or symbol" if !args.car.symbol? && !args.car.string?
+      return if args.cdr.nil?
+      puts
+      puts "  #{args.car.to_s}"
+      args.cdr.each do |clause|
+        clause.evaluate(env)
+      end
+    end
+
+    def self.do_comparison(c1, c2)
+      return Lisp::TRUE if c1.nil? && c2.nil?
+      return Lisp::FALSE if c1.nil? || c2.nil?
+      Lisp::Boolean.with_value(c1.eq?(c2))
+    end
+
+    def self.eval_check(code, c1, c2, inverted)
+      check_result = self.do_comparison(c1, c2)
+      passed = inverted ? check_result.negate : check_result
+      
+      if passed.true?
+        @@number_of_passes += 1
+        puts "ok"
+      else
+        @@number_of_fails += 1
+        message = "failed: #{code.print_string} is #{c1.print_string}, expected #{inverted ? 'not ' : ''}#{c2.print_string}"
+        puts message
+        @@failure_messages << message
+      end
+    end
+
+
+    def self.unary_check(name,sexpr, env, inverted)
+      print "    (#{name} #{sexpr.print_string}) - "
+      c1 = sexpr.evaluate(env)
+      self.eval_check(sexpr, c1, inverted ? Lisp::FALSE : Lisp::TRUE, false)
+    end
+
+
+    def self.binary_check(name, sexpr_1, sexpr_2, env, inverted)
+      print "    (#{name} "
+      print "#{sexpr_1.print_string} "
+      print "#{sexpr_2.print_string}) - "
+      c1 = sexpr_1.evaluate(env)
+      c2 = sexpr_2.evaluate(env)
+      self.eval_check(sexpr_1, c1, c2, inverted)
+    end
+    
+    
+    def self.check_impl(args, env, inverted=false)
+      @@number_of_tests += 1
+      name = inverted ? "check!" : "check"
+      Lisp::Boolean.with_value(case (args.length)
+                               when 1
+                                   self.unary_check(name, args.car, env, inverted)
+                               when 2
+                                   self.binary_check(name, args.car, args.cadr, env, inverted)
+                               else
+                                   raise "check takes 1 or 2 arguments, received #{args.length}"
+                               end)
+    end
+
+    
+    def self.check_not_impl(args, env)
+      self.check_impl(args, env, true)
+    end
+    
+    
+    def self.check_star_impl(args, env)
+      raise "check* needs 2 arguments, received #{args.length}" if args.length != 2
+      @@number_of_tests += 1
+      print "    (check* #{args.car.print_string} #{args.cadr.print_string}) - "
+      
+      c1 = args.car.evaluate(env)
+      c2 = args.cadr
+      self.eval_check(args.car, c1, c2, false)
+    end
+    
+    def self.init
+      @@number_of_tests = 0
+      @@number_of_fails = 0
+      @@number_of_passes = 0
+      @@number_of_errors = 0
+      @@failure_messages = []
+      @@error_messages = []
+    end
+    
+    def self.dump_messages(header, messages)
+      return if messages.empty?
+      puts "  #{header}:"
+      messages.each do |message|
+        puts "    #{message}"
+      end
+      puts ""
+    end
+    
+    def self.print_test_results
+      puts ""
+      puts "  Done."
+      puts ""
+      
+      dump_messages("Errors", @@error_messages)
+      dump_messages("Failures", @@failure_messages)
+      
+      puts "  #{@@number_of_tests} Lisp tests"
+      puts "  #{@@number_of_passes} passes, #{@@number_of_fails} fails, #{@@number_of_errors} errors"
+    end
+  
+    def self.run_tests
+      register
+      init
+      Dir[File.dirname(__FILE__) + '/../../lisptest/*_test.lsp'].each do |test_filename|
+        puts "\nLoading #{test_filename}"
+        File.open(test_filename) do |f|
+          code_string = f.read()
+          Parser.new.parse_and_eval_all(code_string)
+        end
+      end
+      print_test_results
+      @@number_of_errors == 0 && @@number_of_fails == 0
+    end
+
+  end
+end

data/lib/rubylisp/tokenizer.rb

@@ -0,0 +1,292 @@
+module Lisp
+
+  class Tokenizer
+
+    attr_reader :line_number
+
+    def initialize(src)
+      @lookahead_token = 0
+      @lookahead_literal = ''
+      @source = src
+      @position = 0
+    end
+
+    def next_token
+      return @lookahead_token, @lookahead_literal
+    end
+
+    def eof?
+      @position >= @source.length
+    end
+
+    def almost_eof?
+      @position == @source.length - 1
+    end
+
+    def next_char
+      almost_eof? ? nil : @source[@position + 1]
+    end
+
+    def letter?(ch)
+      ch =~ /[[:alpha:]]/
+    end
+
+    def hex?(ch)
+      ch =~ /[abcdefABCDEF]/
+    end
+
+    def digit?(ch)
+      ch =~ /[[:digit:]]/
+    end
+
+    def number?(ch)
+      digit?(ch) || (ch == '-' && digit?(next_char))
+    end
+
+
+    def space?(ch)
+      ch =~ /[[:space:]]/
+    end
+
+
+    def symbol_character?(ch)
+      return true if letter?(ch)
+      return true if (?0..?9).include?(ch)
+      return "-_?!:*=<>".include?(ch)
+    end
+
+    def read_symbol
+      start = @position
+      tok = nil
+      if @source[@position] == '.'
+        @position += 1
+        tok = :FFI_SEND_SYMBOL
+      end
+
+      while !eof? && (symbol_character?(@source[@position]) ||
+                      (@source[@position] == '.' && !symbol_character?(@source[@position+1]) && tok.nil?) ||
+                      (@source[@position] == '/' && symbol_character?(@source[@position+1])))
+        tok ||= :FFI_NEW_SYMBOL if @source[@position] == '.'
+        tok = :FFI_STATIC_SYMBOL if @source[@position] == '/'
+        @position += 1
+      end
+
+      tok ||= :SYMBOL
+      return tok, case tok
+                  when :SYMBOL, :FFI_STATIC_SYMBOL
+                    @source[start...@position]
+                  when :FFI_SEND_SYMBOL
+                    @source[start+1...@position]
+                  when :FFI_NEW_SYMBOL
+                    @source[start...@position-1]
+                  end
+    end
+
+    def read_number
+      start = @position
+      @position += 1 if @source[@position] == '-'
+      hex = @source[@position, 2] == "#x"
+      is_float = false
+      @position += 2 if hex
+      ch = @source[@position]
+      while !eof? && (digit?(ch) || (hex && hex?(ch)) || (!hex && !is_float && ch == ?.))
+        is_float ||= (ch == ?.)
+        @position += 1
+        ch = @source[@position]
+      end
+
+      tok = if hex
+              :HEXNUMBER
+            elsif is_float
+              :FLOAT
+            else
+              :NUMBER
+            end
+
+      return tok, @source[start...@position]
+    end
+
+
+    def process_escapes(str)
+      i = 0
+      processed_str = ""
+      while i < str.length
+        if str[i] == ?\\
+          processed_str << if i < (str.length - 1)
+                             i += 1
+                             case (str[i])
+                             when ?n
+                               "\n"
+                             when ?t
+                               "\t"
+                             when ?\\
+                               "\\"
+                             else
+                               "\\#{str[i]}"
+                             end
+                           else
+                             "\\"
+                           end
+        else
+          processed_str << str[i]
+        end
+        i += 1
+      end
+      processed_str
+    end
+
+
+    def read_string
+      start = @position
+      @position += 1
+      while !eof? && @source[@position] != ?"
+        @position += 1
+      end
+
+      return :EOF, '' if eof?
+      @position += 1
+      return :STRING, process_escapes(@source[start...@position])
+    end
+
+
+    def divider?(ch)
+      ch =~ /[[[:space:]]\(\)\{\}<>\[\]]/
+    end
+
+
+    def read_character
+      @position += 2
+      start = @position
+      @position += 1
+      while !eof? && !divider?(@source[@position])
+        @position += 1
+      end
+
+      return :CHARACTER, @source[start...@position]
+    end
+
+
+    def read_next_token
+      return :EOF, '' if eof?
+
+      while space?(@source[@position])
+        @line_number += 1 if @source[@position] == ?\n
+        @position += 1
+        return :EOF, '' if eof?
+      end
+
+      current_ch = @source[@position]
+      next_ch = @source[@position + 1] unless almost_eof?
+
+      if letter?(current_ch) || ('*._'.include?(current_ch) && letter?(next_ch))
+        return read_symbol
+      elsif number?(current_ch)
+        return read_number
+      elsif current_ch == ?- && number?(next_ch)
+        return read_number
+      elsif current_ch == ?# && next_ch == ?x
+        return read_number
+      elsif current_ch == ?"
+        return read_string
+      elsif current_ch == ?# && next_ch == ?\\
+        return read_character
+      elsif current_ch == ?'
+        @position += 1
+        return :QUOTE, "'"
+      elsif current_ch == ?`
+        @position += 1
+        return :BACKQUOTE, "`"
+      elsif current_ch == ?, && next_ch == ?@
+        @position += 2
+        return :COMMAAT, ",@"
+      elsif current_ch == ?,
+        @position += 1
+        return :COMMA, ","
+      elsif current_ch == ?(
+        @position += 1
+        return :LPAREN, "("
+      elsif current_ch == ?)
+        @position += 1
+        return :RPAREN, ")"
+      elsif current_ch == ?{
+        @position += 1
+        return :LBRACE, "{"
+      elsif current_ch == ?}
+        @position += 1
+        return :RBRACE, "}"
+      elsif current_ch == ?[
+        @position += 1
+        return :LBRACKET, "["
+      elsif current_ch == ?]
+        @position += 1
+        return :RBRACKET, "]"
+      elsif current_ch == ?.
+        @position += 1
+        return :PERIOD, "."
+      elsif current_ch == ?/ && next_ch == ?=
+        @position += 2
+        return :SYMBOL, "!="
+      elsif current_ch == ?- && next_ch == ?>
+        @position += 2
+        return :SYMBOL, "->"
+      elsif current_ch == ?= && next_ch == ?>
+        @position += 2
+        return :SYMBOL, "=>"
+      elsif "+-*/%".include?(current_ch)
+        @position += 1
+        return :SYMBOL, current_ch.to_s
+      elsif current_ch == ?< && next_ch == ?=
+        @position += 2
+        return :SYMBOL, "<="
+      elsif current_ch == ?<
+        @position += 1
+        return :SYMBOL, "<"
+      elsif current_ch == ?> && next_ch == ?=
+        @position += 2
+        return :SYMBOL, ">="
+      elsif current_ch == ?>
+        @position += 1
+        return :SYMBOL, ">"
+      elsif current_ch == ?= && next_ch == ?=
+        @position += 2
+        return :SYMBOL, "="
+      elsif current_ch == ?=
+        @position += 1
+        return :SYMBOL, "="
+      elsif current_ch == ?! && next_ch == ?=
+        @position += 2
+        return :SYMBOL, "!="
+      elsif current_ch == ?!
+        @position += 1
+        return :SYMBOL, "!"
+      elsif current_ch == ?# && next_ch == ?t
+        @position += 2
+        return :TRUE, "#t"
+      elsif current_ch == ?# && next_ch == ?f
+        @position += 2
+        return :FALSE, "#f"
+      elsif current_ch == ?;
+        start = @position
+        while true
+          return :COMMENT, @source[start..-1] if eof?
+          return :COMMENT, @source[start...@position] if @source[@position] == ?\n
+          @position += 1
+        end
+      else
+        return :ILLEGAL, ''
+      end
+    end
+
+    def consume_token
+      @lookahead_token, @lookahead_literal = read_next_token
+      consume_token if @lookahead_token == :COMMENT
+    end
+
+    def init
+      @line_number = 0
+      consume_token
+    end
+
+  end
+
+end

data/lib/rubylisp/type_checks.rb

@@ -0,0 +1,58 @@
+module Lisp
+
+  class TypeChecks
+
+    def self.register
+      Primitive.register("list?")     {|args, env| Lisp::TypeChecks::typep_impl("list?", :pair, args, env) }
+      Primitive.register("pair?")     {|args, env| Lisp::TypeChecks::typep_impl("pair?", :pair, args, env) }
+      Primitive.register("symbol?")   {|args, env| Lisp::TypeChecks::typep_impl("symbol?", :symbol, args, env) }
+      Primitive.register("number?")   {|args, env| Lisp::TypeChecks::typep_impl("number?", :number, args, env) }
+      Primitive.register("integer?")   {|args, env| Lisp::TypeChecks::integerp_impl(args, env) }
+      Primitive.register("float?")   {|args, env| Lisp::TypeChecks::floatp_impl(args, env) }
+      Primitive.register("function?") {|args, env| Lisp::TypeChecks::functionp_impl(args, env) }
+
+      Primitive.register("nil?")      {|args, env| Lisp::TypeChecks::nilp_impl(args, env) }
+      Primitive.register("not-nil?")  {|args, env| Lisp::TypeChecks::not_nilp_impl(args, env) }
+    end
+
+
+    def self.typep_impl(name, sym, args, env)
+      raise "#{name} needs 1 argument" unless args.length == 1
+      return Lisp::Boolean.with_value(args.car.evaluate(env).type == sym)
+    end
+
+
+    def self.integerp_impl(args, env)
+      raise "integer? needs 1 argument" unless args.length == 1
+      val = args.car.evaluate(env)
+      return Lisp::Boolean.with_value(val.type == :number && val.integer?)
+    end
+
+
+    def self.floatp_impl(args, env)
+      raise "float? needs 1 argument" unless args.length == 1
+      val = args.car.evaluate(env)
+      return Lisp::Boolean.with_value(val.type == :number && val.float?)
+    end
+
+
+    def self.functionp_impl(args, env)
+      raise "function? needs 1 argument" unless args.length == 1
+      val = args.car.evaluate(env)
+      return Lisp::Boolean.with_value(val.type == :function || val.type == :primitive)
+    end
+
+
+    def self.nilp_impl(args, env)
+      raise "nil? needs 1 argument" unless args.length == 1
+      return Lisp::Boolean.with_value(args.car.evaluate(env).nil?)
+    end
+
+
+    def self.not_nilp_impl(args, env)
+      raise "not-nil? needs 1 argument" unless args.length == 1
+      return Lisp::Boolean.with_value(!args.car.evaluate(env).nil?)
+    end
+
+  end
+end

data/lib/rubylisp/vector.rb

@@ -0,0 +1,114 @@
+module Lisp
+
+  class Vector < Atom
+
+    def self.register
+      Primitive.register("make-vector")   {|args, env| Lisp::Vector::make_vector_impl(args, env) }
+      Primitive.register("vector")   {|args, env| Lisp::Vector::vector_impl(args, env) }
+    end
+
+    def self.make_vector_impl(args, env)
+      c = args
+      a = []
+      while !c.nil?
+        a << c.car.evaluate(env)
+        c = c.cdr
+      end
+
+      Lisp::Vector.new(a)
+    end
+  
+
+    def self.vector_impl(args, env)
+      raise "vector requires a single list argument." unless args.length == 1
+      
+      c = args.car.evaluate(env)
+      Lisp::Vector.new(c.to_a)
+    end
+  
+
+    def self.with_array(a)
+      self.new(a)
+    end
+
+    
+    def initialize(a = [])
+      @value = a
+      self
+    end
+
+
+    def type
+      :vector
+    end
+
+
+    def vector?
+      true
+    end
+
+
+
+    def empty?
+      @value.empty?
+    end
+
+
+    def length
+      @value.size
+    end
+
+
+    def add(e)
+      @value << e
+    end
+
+
+    def to_a
+      @value
+    end
+    
+
+    def to_s
+      "[#{@value.join(' ')}]"
+    end
+
+
+    def at(n)
+      @value[n - 1]
+    end
+    alias_method :nth, :at
+
+
+    def nth_tail(n)
+      return Lisp::Vector.new if n > @value.size
+      Lisp::Vector.new(@value[(n - 1)..-1])
+    end
+    
+    
+    def at_put(n, d)
+      @value[n - 1] = d
+    end
+
+
+    def set_nth!(n, d)
+      at_put(n, d)
+    end
+
+
+    def eq?(other)
+      return false unless other.vector?
+      return false unless @value.size == other.value.size
+      (0..@value.size).each do |i|
+        return false unless Lisp::Equivalence.equal_check(other.value[i], value[i]).value
+      end
+      true
+    end
+
+    def each &block
+      @value.each &block
+    end
+
+  end
+
+end

data/lib/rubylisp.rb

@@ -0,0 +1 @@
+Dir[File.dirname(__FILE__) + '/rubylisp/*.rb'].each {|file| require file }