rubylisp 0.2.1 → 1.0.2

data/lib/rubylisp/prim_list_support.rb

@@ -0,0 +1,496 @@
+module Lisp
+
+  class PrimListSupport
+
+    def self.register
+      %w(car cdr caar cadr cdar cddr
+         caaar caadr cadar caddr cdaar cdadr cddar cdddr
+         caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+         cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr).each do |name|
+        Primitive.register(name, "1")        {|args, env| ad_impl(args, env, name) }
+      end
+
+      Primitive.register("list", "*")        {|args, env|  Lisp::PrimListSupport::list_impl(args, env) }
+      Primitive.register("cons*", "*")       {|args, env|  Lisp::PrimListSupport::cons_star_impl(args, env) }
+      Primitive.register("cons", "2")        {|args, env|  Lisp::PrimListSupport::cons_impl(args, env) }
+      Primitive.register("make-list", "1|2") {|args, env|  Lisp::PrimListSupport::make_list_impl(args, env) }
+      Primitive.register("iota", "1|2|3")    {|args, env|  Lisp::PrimListSupport::iota_impl(args, env) }
+
+      Primitive.register("length", "1")      {|args, env|  Lisp::PrimListSupport::length_impl(args, env) }
+      Primitive.register("first", "1")       {|args, env|  Lisp::PrimListSupport::first_impl(args, env) }
+      Primitive.register("head", "1")        {|args, env|  Lisp::PrimListSupport::first_impl(args, env) }
+      Primitive.register("rest", "1")        {|args, env|  Lisp::PrimListSupport::rest_impl(args, env) }
+      Primitive.register("tail", "1")        {|args, env|  Lisp::PrimListSupport::rest_impl(args, env) }
+      Primitive.register("second", "1")      {|args, env|  Lisp::PrimListSupport::second_impl(args, env) }
+      Primitive.register("third", "1")       {|args, env|  Lisp::PrimListSupport::third_impl(args, env) }
+      Primitive.register("fourth", "1")      {|args, env|  Lisp::PrimListSupport::fourth_impl(args, env) }
+      Primitive.register("fifth", "1")       {|args, env|  Lisp::PrimListSupport::fifth_impl(args, env) }
+      Primitive.register("sixth", "1")       {|args, env|  Lisp::PrimListSupport::sixth_impl(args, env) }
+      Primitive.register("seventh", "1")     {|args, env|  Lisp::PrimListSupport::seventh_impl(args, env) }
+      Primitive.register("eighth", "1")      {|args, env|  Lisp::PrimListSupport::eighth_impl(args, env) }
+      Primitive.register("ninth", "1")       {|args, env|  Lisp::PrimListSupport::ninth_impl(args, env) }
+      Primitive.register("tenth", "1")       {|args, env|  Lisp::PrimListSupport::tenth_impl(args, env) }
+      Primitive.register("nth", "2")         {|args, env|  Lisp::PrimListSupport::nth_impl(args, env) }
+
+      Primitive.register("sublist", "3")     {|args, env|  Lisp::PrimListSupport::sublist_impl(args, env) }
+      Primitive.register("list-head", "2")   {|args, env|  Lisp::PrimListSupport::list_head_impl(args, env) }
+      Primitive.register("take", "2")        {|args, env|  Lisp::PrimListSupport::take_impl(args, env) }
+      Primitive.register("list-tail", "2")   {|args, env|  Lisp::PrimListSupport::list_tail_impl(args, env) }
+      Primitive.register("drop", "2")        {|args, env|  Lisp::PrimListSupport::drop_impl(args, env) }
+      Primitive.register("last-pair", "1")   {|args, env|  Lisp::PrimListSupport::last_pair_impl(args, env) }
+
+      Primitive.register("memq", "2")        {|args, env|  Lisp::PrimListSupport::memq_impl(args, env) }
+      Primitive.register("memv", "2")        {|args, env|  Lisp::PrimListSupport::memv_impl(args, env) }
+      Primitive.register("member", "2")      {|args, env|  Lisp::PrimListSupport::member_impl(args, env) }
+
+      Primitive.register("filter", "2")      {|args, env| Lisp::PrimListSupport::filter_impl(args, env) }
+      Primitive.register("remove", "2")      {|args, env| Lisp::PrimListSupport::remove_impl(args, env) }
+      Primitive.register("partition", "2")   {|args, env| Lisp::PrimListSupport::partition_impl(args, env) }
+      Primitive.register("map", ">=2")       {|args, env| Lisp::PrimListSupport::map_impl(args, env) }
+      Primitive.register("for-each", ">=2")  {|args, env| Lisp::PrimListSupport::for_each_impl(args, env) }
+      Primitive.register("reduce-left", "3") {|args, env| Lisp::PrimListSupport::reduce_left_impl(args, env) }
+      Primitive.register("any", ">=2")       {|args, env| Lisp::PrimListSupport::any_impl(args, env) }
+      Primitive.register("every", ">=2")     {|args, env| Lisp::PrimListSupport::every_impl(args, env) }
+      Primitive.register("reverse", "1")     {|args, env| Lisp::PrimListSupport::reverse_impl(args, env) }
+      Primitive.register("append", ">=1")    {|args, env| Lisp::PrimListSupport::append_impl(args, env) }
+      Primitive.register("append!", ">=1")   {|args, env| Lisp::PrimListSupport::appendbang_impl(args, env) }
+      Primitive.register("flatten", "1")     {|args, env| Lisp::PrimListSupport::flatten_impl(args, env) }
+      # Primitive.register("flatten*")     {|args, env| Lisp::PrimListSupport::recursive_flatten_impl(args, env) }
+    end
+
+
+    def self.cons_impl(args, env)
+      Lisp::ConsCell.cons(args.car, args.cadr)
+    end
+
+
+    def self.cons_star_impl(args, env)
+      return args.car if args.length == 1
+      arg_ary = args.to_a
+      Lisp::ConsCell::array_to_list(arg_ary[0..-2], arg_ary[-1])
+    end
+
+
+    def self.list_impl(args, env)
+      args
+    end
+
+
+    def self.make_list_impl(args, env)
+      return Lisp::Debug.process_error("make-list requires an integer for it's first argument, received: #{args.car}", env) unless args.car.integer?
+      count = args.car.value
+      val = if args.length == 1
+              nil
+            else
+              args.cadr
+            end
+
+      vals = Array.new(count, val)
+      Lisp::ConsCell::array_to_list(vals)
+    end
+
+
+    def self.iota_impl(args, env)
+      arg1 = args.car
+      return Lisp::Debug.process_error("iota requires an positive integer for it's first argument, received: #{arg1}", env) unless arg1.integer? && arg1.positive?
+      count = arg1.value
+
+      start = if args.length < 2
+                0
+              else
+                arg2 = args.cadr
+                return Lisp::Debug.process_error("iota requires an number for it's second argument, received: #{arg2}", env) unless arg2.number?
+                arg2.value
+              end
+
+      step = if args.length < 3
+                1
+              else
+                arg3 = args.caddr
+                return Lisp::Debug.process_error("iota requires an number for it's third argument, received: #{arg3}", env) unless arg3.number?
+                arg3.value
+              end
+
+      vals = []
+      count.times do |c|
+        vals << start
+        start += step
+      end
+
+      Lisp::ConsCell::array_to_list(vals.map {|v| Number.with_value(v) })
+    end
+
+
+    def self.length_impl(args, env)
+      Lisp::Number.with_value(args.car.length)
+    end
+
+
+    # in support of all the CxR functions
+    def self.ad_impl(args, env, f)
+      l = args.car
+      return Lisp::Debug.process_error("list required.", env) unless l.list?
+      l.send(f)
+    end
+
+
+    def self.first_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      return Lisp::Debug.process_error("list index out of bounds", env) unless l.length >= 1
+      l.nth(0)
+    end
+
+
+    def self.rest_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      l.cdr
+    end
+
+
+    def self.second_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      return Lisp::Debug.process_error("list index out of bounds", env) unless l.length >= 2
+      l.nth(1)
+    end
+
+    def self.third_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      return Lisp::Debug.process_error("list index out of bounds", env) unless l.length >= 3
+      l.nth(2)
+    end
+
+
+    def self.fourth_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      return Lisp::Debug.process_error("list index out of bounds", env) unless l.length >= 4
+      l.nth(3)
+    end
+
+
+    def self.fifth_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      return Lisp::Debug.process_error("list index out of bounds", env) unless l.length >= 5
+      l.nth(4)
+    end
+
+
+    def self.sixth_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      return Lisp::Debug.process_error("list index out of bounds", env) unless l.length >= 6
+      l.nth(5)
+    end
+
+
+    def self.seventh_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      return Lisp::Debug.process_error("list index out of bounds", env) unless l.length >= 7
+      l.nth(6)
+    end
+
+
+    def self.eighth_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      return Lisp::Debug.process_error("list index out of bounds", env) unless l.length >= 8
+      l.nth(7)
+    end
+
+
+    def self.ninth_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      return Lisp::Debug.process_error("list index out of bounds", env) unless l.length >= 9
+      l.nth(8)
+    end
+
+
+    def self.tenth_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      return Lisp::Debug.process_error("list index out of bounds", env) unless l.length >= 10
+      l.nth(9)
+    end
+
+
+    def self.nth_impl(args, env)
+      n = args.car
+      return Lisp::Debug.process_error("The first argument of nth has to be an number.", env) unless n.number?
+      return Lisp::Debug.process_error("The first argument of nth has to be non-negative.", env) unless n.value >= 0
+      l = args.cadr
+      return Lisp::Debug.process_error("rest requires a list.", env) unless l.list?
+      l.nth(n.value)
+    end
+
+
+    def self.make_same_kind_as(sequence, value)
+      if sequence.vector?
+        Lisp::Vector.new(value)
+      else
+        Lisp::ConsCell.array_to_list(value)
+      end
+    end
+    
+
+    def self.sublist_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("sublist requires it's first argument to be a list, but received #{l}", env) unless l.list?
+      st = args.cadr
+      return Lisp::Debug.process_error("sublist requires it's second argument to be a non-negative integer, but received #{st}", env) unless st.number? && st.value >= 0
+      return Lisp::Debug.process_error("sublist requires it's second argument to be <= the list length", env) unless st.value < l.length
+      en = args.caddr
+      return Lisp::Debug.process_error("sublist requires it's third argument to be a non-negative integer, but received #{en}", env) unless en.number? && en.value >= 0
+      return Lisp::Debug.process_error("sublist requires it's third argument to be <= the list length", env) unless en.value < l.length
+      return Lisp::Debug.process_error("sublist requires it's second argument to be <= the third argument", env) unless st.value <= en.value
+      Lisp::ConsCell.array_to_list(l.to_a[st.value...en.value])
+    end
+
+
+    def self.list_head_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("list_head requires it's first argument to be a list, but received #{l}", env) unless l.list?
+      k = args.cadr
+      return Lisp::Debug.process_error("list_head requires it's second argument to be a non-negative integer, but received #{k}", env) unless k.number? && k.value >= 0
+      return Lisp::Debug.process_error("list_head requires it's second argument to be <= the list length", env) unless k.value <= l.length
+      Lisp::ConsCell.array_to_list(l.to_a[0...k.value])
+    end
+
+
+    def self.take_impl(args, env)
+      k = args.car
+      return Lisp::Debug.process_error("take requires it's first argument to be a non-negative integer, but received #{k}", env) unless k.number? && k.value >= 0
+      l = args.cadr
+      return Lisp::Debug.process_error("take requires it's second argument to be a list, but received #{l}", env) unless l.list?
+      return Lisp::Debug.process_error("take requires it's first argument to be <= the list length", env) unless k.value <= l.length
+      Lisp::ConsCell.array_to_list(l.to_a[0...k.value])
+    end
+
+
+    def self.list_tail_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("list_head requires it's first argument to be a list, but received #{l}", env) unless l.list?
+      k = args.cadr
+      return Lisp::Debug.process_error("list_head requires it's second argument to be a non-negative integer, but received #{k}", env) unless k.number? && k.value >= 0
+      return Lisp::Debug.process_error("list_head requires it's second argument to be <= the list length", env) unless k.value <= l.length
+      l.nth_tail(k.value)
+    end
+
+
+    def self.drop_impl(args, env)
+      k = args.car
+      return Lisp::Debug.process_error("drop requires it's first argument to be an integer >= 0, but received #{l}", env) unless k.number? && k.value >= 0
+      l = args.cadr
+      return Lisp::Debug.process_error("drop requires it's second argument to be a list, but received #{l}", env) unless l.list?
+      return Lisp::Debug.process_error("drop requires it's first argument to be <= the list length", env) unless k.value <= l.length
+      l.nth_tail(k.value)
+    end
+
+
+    def self.last_pair_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("last_pair requires it's argument to be a list, but received #{l}", env) unless l.list?
+      l.last
+    end
+
+
+    def self.memq_impl(args, env)
+      item = args.car
+      collection = args.cadr
+      return Lisp::Debug.process_error("memq requires a list as it's second argument.", env) unless collection.list?
+      collection.length.times do |i|
+        if item.eq?(collection.nth(i))
+          return collection.nth_tail(i)
+        end
+      end
+      Lisp::FALSE
+    end
+
+
+    def self.memv_impl(args, env)
+      item = args.car
+      collection = args.cadr
+      return Lisp::Debug.process_error("memv requires a list as it's second argument.", env) unless collection.list?
+      collection.length.times do |i|
+        if item.eqv?(collection.nth(i))
+          return collection.nth_tail(i)
+        end
+      end
+      Lisp::FALSE
+    end
+
+
+    def self.member_impl(args, env)
+      item = args.car
+      collection = args.cadr
+      return Lisp::Debug.process_error("member requires a list as it's second argument.", env) unless collection.list?
+      collection.length.times do |i|
+        if item.equal?(collection.nth(i))
+          return collection.nth_tail(i)
+        end
+      end
+      Lisp::FALSE
+    end
+
+
+    def self.filter_impl(args, env)
+      f = args.car
+      return Lisp::Debug.process_error("filter requires a function as it's first argument but received #{args.car}.", env) unless f.function? || f.primitive?
+      collection = args.cadr
+      return Lisp::Debug.process_error("filter requires a list as it's second argument but received #{args.cadr}.", env) unless collection.list?
+      results = collection.to_a.select {|item| f.apply_to_without_evaluating(Lisp::ConsCell.cons(item, nil), env).value }
+      Lisp::ConsCell.array_to_list(results)
+    end
+
+
+    def self.remove_impl(args, env)
+      f = args.car
+      return Lisp::Debug.process_error("remove requires a function as it's first argument but received #{args.car}.", env) unless f.function? || f.primitive?
+      collection = args.cadr
+      return Lisp::Debug.process_error("remove requires a list as it's second argument but received #{args.cadr}.", env) unless collection.list?
+      results = collection.to_a.reject {|item| f.apply_to_without_evaluating(Lisp::ConsCell.cons(item, nil), env).value }
+      Lisp::ConsCell.array_to_list(results)
+    end
+
+
+    def self.partition_impl(args, env)
+      f = args.car
+      return Lisp::Debug.process_error("partition requires a function as it's first argument.", env) unless f.function? || f.primitive?
+      collection = args.cadr
+      return Lisp::Debug.process_error("partition requires a list as it's second argument.", env) unless collection.list?
+      results = collection.to_a.partition {|item| f.apply_to_without_evaluating(Lisp::ConsCell.cons(item, nil), env).value }
+      matches = Lisp::ConsCell.array_to_list(results[0])
+      non_matches = Lisp::ConsCell.array_to_list(results[1])
+      Lisp::ConsCell.array_to_list([matches, non_matches])
+    end
+
+
+    def self.map_impl(args, env)
+      f = args.car
+      return Lisp::Debug.process_error("map requires a function as it's first argument but received #{args.car}.", env) unless f.function? || f.primitive?
+      collections = args.cdr.to_a
+      return Lisp::Debug.process_error("map requires all subsequent arguments to be lists", env) unless collections.all? {|l| l.list?}
+      lists = collections.collect {|l| l.to_a }
+      
+      map_args = []
+      while (lists.all? {|l| !l.empty? })
+        map_args << Lisp::ConsCell.array_to_list(lists.map {|l| l.shift })
+      end
+      results = map_args.collect {|item| f.apply_to_without_evaluating(item, env) }
+      Lisp::ConsCell.array_to_list(results)
+    end
+
+
+    def self.for_each_impl(args, env)
+      f = args.car
+      return Lisp::Debug.process_error("for-each requires a function as it's first argument but received #{args.car}.", env) unless f.function? || f.primitive?
+      collections = args.cdr
+      return Lisp::Debug.process_error("for-each requires all subsequent arguments to be lists", env) unless collections.all? {|l| l.list?}
+      lists = collections.collect {|l| l.to_a }
+      
+      map_args = []
+      while (lists.all? {|l| !l.empty? })
+        map_args << Lisp::ConsCell.array_to_list(lists.map {|l| l.shift })
+      end
+      map_args.collect {|item| f.apply_to_without_evaluating(item, env) }
+
+      nil
+    end
+
+
+    def self.quote_if_required(thing)
+      return thing unless thing.list? || thing.symbol?
+      thing.quoted
+    end
+
+
+    def self.reduce_left_impl(args, env)
+      f = args.car
+      return Lisp::Debug.process_error("reduce-left requires a function as it's first argument but received #{args.car}.", env) unless f.function? || f.primitive?
+      initial = args.cadr
+      collection = args.caddr
+      return Lisp::Debug.process_error("reduce-left requires a list as it's third argument but received #{args.caddr}.", env) unless collection.list?
+      return initial if collection.empty?
+      return collection.nth(0) if collection.length == 1
+      collection.to_a.inject do |acc, item|
+        f.apply_to_without_evaluating(Lisp::ConsCell.array_to_list([acc, item]), env)
+      end
+    end
+
+
+    def self.any_impl(args, env)
+      p = args.car
+      return Lisp::Debug.process_error("any requires a function as it's first argument", env) unless p.function? || p.primitive?
+      lists = args.cdr.to_a
+      return Lisp::Debug.process_error("any requires all subsequent arguments to be lists", env) unless lists.all? {|l| l.list?}
+
+      while true
+        cars = lists.collect {|l| l.nth(0)}
+        return_val = p.apply_to(Lisp::ConsCell.array_to_list(cars), env)
+        return Lisp::TRUE if return_val.value
+        lists = lists.collect {|l| l.nth_tail(1)}
+        return Lisp::FALSE if lists.any? {|l| l.empty?}
+      end
+    end
+
+
+    def self.every_impl(args, env)
+      p = args.car
+      return Lisp::Debug.process_error("every requires a function as it's first argument", env) unless p.function? || p.primitive?
+      lists = args.cdr.to_a
+      return Lisp::Debug.process_error("every requires all subsequent arguments to be lists", env) unless lists.all? {|l| l.list?}
+
+      
+      while true
+        cars = lists.collect {|l| l.nth(0)}
+        return_val = p.apply_to(Lisp::ConsCell.array_to_list(cars), env)
+        return Lisp::FALSE unless return_val.value
+        lists = lists.collect {|l| l.nth_tail(1)}
+        return Lisp::TRUE if lists.any? {|l| l.empty?}
+      end
+    end
+
+
+    def self.reverse_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("reverse requires a list", env) unless l.list?
+      Lisp::ConsCell.array_to_list(l.to_a.reverse)
+    end
+
+
+    def self.append_impl(args, env)
+      l = args
+      return Lisp::Debug.process_error("append requires lists", env) unless l.all? {|i| i.list? }
+      new_items = []
+      l.each do |sublist|
+        sublist.each {|item| new_items << item.copy}
+      end
+
+      Lisp::ConsCell.array_to_list(new_items)
+    end
+
+
+    def self.appendbang_impl(args, env)
+      arg_array = args.to_a
+      return Lisp::Debug.process_error("append! requires lists", env) unless arg_array.all? {|i| i.list?}
+      (0...(arg_array.length-1)). each do |i|
+        arg_array[i].last.set_cdr!(arg_array[i+1])
+      end
+      arg_array[0]
+    end
+
+
+    def self.flatten_impl(args, env)
+      l = args.car
+      return Lisp::Debug.process_error("flatten requires a list argument", env) unless l.list?
+      l.flatten
+    end
+
+  end
+end

data/lib/rubylisp/{logical.rb → prim_logical.rb}

@@ -1,37 +1,32 @@
 module Lisp
 
-  class Logical
+  class PrimLogical
 
     def self.register
-      Primitive.register("or",
+      Primitive.register("or", ">=2",
                          "(or expression ...\n\nThe expressions are evaluated from left to right, and the value of the first expression that evaluates to a true value is returned. Any remaining expressions are not evaluated. If all expressions evaluate to false values, the value of the last expression is returned. If there are no expressions then #f is returned.",
                          true)  do |args, env|
-                           Lisp::Logical::or_impl(args, env)
+                           Lisp::PrimLogical::or_impl(args, env)
                          end
-      Primitive.register("and",
+      Primitive.register("and", ">=2",
                          "(and expression ...)\n\nThe expressions are evaluated from left to right, and the value of the first expression that evaluates to a false value is returned. Any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then #t is returned.",
                          true) do |args, env|
-                           Lisp::Logical::and_impl(args, env)
+                           Lisp::PrimLogical::and_impl(args, env)
                          end
-      Primitive.register("not") {|args, env| Lisp::Logical::not_impl(args, env) }
+      Primitive.register("not", "1") {|args, env| Lisp::PrimLogical::not_impl(args, env) }
     end
 
 
     def self.or_impl(args, env)
-      return Lisp::Debug.process_error("or needs at least 2 arguments", env) unless args.length > 1
-      value = !!args.inject(false) {|acc, item| acc || item.evaluate(env).value}
-      return Lisp::Boolean.with_value(value)
+      Lisp::Boolean.with_value(args.inject(false) {|acc, item| acc || item.evaluate(env).value})
     end
 
     def self.and_impl(args, env)
-      return Lisp::Debug.process_error("and needs at least 2 arguments", env) unless args.length > 1
-      value = !!args.inject(true) {|acc, item| acc && item.evaluate(env).value}
-      return Lisp::Boolean.with_value(value)
+      Lisp::Boolean.with_value(args.inject(true) {|acc, item| acc && item.evaluate(env).value})
     end
 
     def self.not_impl(args, env)
-      return Lisp::Debug.process_error("not needs a single argument", env) unless args.length == 1
-      return Lisp::Boolean.with_value(!(args.car.evaluate(env).value))
+      return Lisp::Boolean.with_value(!(args.car.value))
     end
 
   end