rubylisp 0.1.0

data/lib/rubylisp/character.rb

@@ -0,0 +1,383 @@
+# -*- coding: utf-8 -*-
+module Lisp
+
+  class Character < Atom
+
+    def self.register
+      Primitive.register("char->name", "(char->name char)\n\nReturns a string corresponding to the printed representation of char. This is the character or character-name component of the external representation.") do |args, env|
+        Lisp::Character::char_name_impl(args, env)
+      end
+      
+      Primitive.register("name->char", "(name->char string)\n\nConverts a string that names a character into the character specified. If string does not name any character, name->char signals an error.") do |args, env|
+        Lisp::Character::name_char_impl(args, env)
+      end
+      
+      Primitive.register("char=?", "(char=? char1 char2)\n\nReturn whether char1 and char2 are the same") do |args, env|
+        Lisp::Character::char_eq_impl(args, env)
+      end
+      
+      Primitive.register("char<?", "(char<? char1 char2)\n\nReturn whether char1 is less than char2") do |args, env|
+        Lisp::Character::char_lt_impl(args, env)
+      end
+      
+      Primitive.register("char>?", "(char>? char1 char2)\n\nReturn whether char1 is greater than char2") do |args, env|
+        Lisp::Character::char_gt_impl(args, env)
+      end
+      
+      Primitive.register("char<=?", "(char<=? char1 char2)\n\nReturn whether char1 is less than or equal to char2") do |args, env|
+        Lisp::Character::char_lteq_impl(args, env)
+      end
+      
+      Primitive.register("char>=?", "(char>=? char1 char2)\n\nReturn whether char1 is greater than or equal to char2") do |args, env|
+        Lisp::Character::char_gteq_impl(args, env)
+      end
+      
+      Primitive.register("char-ci=?", "(char=? char1 char2)\n\nReturn whether char1 is equal to char2, ignoring case") do |args, env|
+        Lisp::Character::char_ci_eq_impl(args, env)
+      end
+      
+      Primitive.register("char-ci<?", "(char=? char1 char2)\n\nReturn whether char1 is less than char2, ignoring case") do |args, env|
+        Lisp::Character::char_ci_lt_impl(args, env)
+      end
+      
+      Primitive.register("char-ci>?", "(char=? char1 char2)\n\nReturn whether char1 is greater than char2, ignoring case") do |args, env|
+        Lisp::Character::char_ci_gt_impl(args, env)
+      end
+      
+      Primitive.register("char-ci<=?", "(char=? char1 char2)\n\nReturn whether char1 is less than or equal to char2, ignoring case") do |args, env|
+        Lisp::Character::char_ci_lteq_impl(args, env)
+      end
+      
+      Primitive.register("char-ci>=?", "(char=? char1 char2)\n\nReturn whether char1 is greater than orequal to char2, ignoring case") do |args, env|
+        Lisp::Character::char_ci_gteq_impl(args, env)
+      end
+      
+      Primitive.register("char?", "(char? sexpr)\n\nReturns #t if object is a character; otherwise returns #f.") do |args, env|
+        Lisp::Character::charp_impl(args, env)
+      end
+      
+      Primitive.register("char-upcase", "(char-upcase char)\n\nReturns the uppercase equivalent of char if char is a letter; otherwise returns char. These procedures return a character char2 such that (char-ci=? char char2).") do |args, env|
+        Lisp::Character::char_upcase_impl(args, env)
+      end
+      
+      Primitive.register("char-downcase", "(char-downcase char)\n\nReturns the lowercase equivalent of char if char is a letter; otherwise returns char. These procedures return a character char2 such that (char-ci=? char char2).") do |args, env|
+        Lisp::Character::char_downcase_impl(args, env)
+      end
+      
+      Primitive.register("char->digit", "(char->digit char [radix])\n\nIf char is a character representing a digit in the given radix, returns the corresponding integer value. If you specify radix (which must be an integer between 2 and 36 inclusive), the conversion is done in that base, otherwise it is done in base 10. If char doesn’t represent a digit in base radix, char->digit returns #f.\n\nNote that this procedure is insensitive to the alphabetic case of char.") do |args, env|
+        Lisp::Character::char_digit_impl(args, env)
+      end
+      
+      Primitive.register("digit->char", "(digit->char digit [radix])\n\nReturns a character that represents digit in the radix given by radix. Radix must be an exact integer between 2 and 36 (inclusive), and defaults to 10. Digit, which must be a non-negative integer, should be less than radix; if digit is greater than or equal to radix, digit->char returns #f.") do |args, env|
+        Lisp::Character::digit_char_impl(args, env)
+      end
+      
+      Primitive.register("char->integer", "(char->integer char)\n\nchar->integer returns the character code representation for char.") do |args, env|
+        Lisp::Character::char_int_impl(args, env)
+      end
+      
+      Primitive.register("integer->char", "(integer->char k)\n\ninteger->char returns the character whose character code representation is k.") do |args, env|
+        Lisp::Character::int_char_impl(args, env)
+      end
+    end
+
+
+    def self.find_character_for_chr(ch)
+      @@character_constants.each_value {|v| return v if v.value == ch}
+      return @@character_constants[ch] = Lisp::Character.new(ch)
+    end
+
+
+    def self.find_character_for_name(n)
+      return @@character_constants[n] if @@character_constants.has_key?(n)
+      if n.length == 1
+        ch = self.new(n[0])
+       return @@character_constants[n] = ch
+      end
+      nil
+    end
+
+
+    def self.char_name_impl(args, env)
+      raise "char->name requires a single argument, found #{args.length}" unless args.length == 1
+      char = args.car.evaluate(env)
+      raise "char->name requires a character argument" unless char.character?
+      kv = @@character_constants.rassoc(char)
+      return Lisp::String.with_value(kv[0]) unless kv.nil?
+      raise "char->name was passed an invalid character"
+    end
+
+
+    def self.name_char_impl(args, env)
+      raise "name->char requires a single argument, found #{args.length}" unless args.length == 1
+      name = args.car.evaluate(env)
+      raise "name->char requires a string argument" unless name.string?
+      ch = find_character_for_name(name.value)
+      return ch unless ch.nil?
+      raise "There is no character with the name #{name}"
+    end
+
+
+    def self.get_one_character_arg(func, args, env)
+      raise "#{func} requires a character argument, found no args" unless args.length >= 1
+      char1 = args.car.evaluate(env)
+      raise "#{func} requires a character argument, found #{char1}" unless char1.character?
+      return char1
+    end
+
+
+    def self.get_two_character_args(func, args, env)
+      raise "#{func} requires two arguments, found #{args.length}" unless args.length == 2
+      char1 = args.car.evaluate(env)
+      raise "#{func} requires character arguments, found #{char1}" unless char1.character?
+      char2 = args.cadr.evaluate(env)
+      raise "#{func} requires character arguments, found #{char2}" unless char2.character?
+      return [char1, char2]
+    end
+
+
+    def self.char_eq_impl(args, env)
+      char1, char2 = get_two_character_args("char=?", args, env)
+      Lisp::Boolean.with_value(char1.value == char2.value)
+    end
+
+
+    def self.char_lt_impl(args, env)
+      char1, char2 = get_two_character_args("char<?", args, env)
+      Lisp::Boolean.with_value(char1.value < char2.value)
+    end
+
+
+    def self.char_gt_impl(args, env)
+      char1, char2 = get_two_character_args("char>?", args, env)
+      Lisp::Boolean.with_value(char1.value > char2.value)
+    end
+
+
+    def self.char_lteq_impl(args, env)
+      char1, char2 = get_two_character_args("char<=?", args, env)
+      Lisp::Boolean.with_value(char1.value <= char2.value)
+    end
+
+
+    def self.char_gteq_impl(args, env)
+      char1, char2 = get_two_character_args("char>=?", args, env)
+      Lisp::Boolean.with_value(char1.value >= char2.value)
+    end
+
+
+    def self.char_ci_eq_impl(args, env)
+      char1, char2 = get_two_character_args("char-ci=?", args, env)
+      Lisp::Boolean.with_value(char1.value.downcase == char2.value.downcase)
+    end
+
+
+    def self.char_ci_lt_impl(args, env)
+      char1, char2 = get_two_character_args("char-ci<?", args, env)
+      Lisp::Boolean.with_value(char1.value.downcase < char2.value.downcase)
+    end
+
+
+    def self.char_ci_gt_impl(args, env)
+      char1, char2 = get_two_character_args("char-ci>?", args, env)
+      Lisp::Boolean.with_value(char1.value.downcase > char2.value.downcase)
+    end
+
+
+    def self.char_ci_lteq_impl(args, env)
+      char1, char2 = get_two_character_args("char-ci<=?", args, env)
+      Lisp::Boolean.with_value(char1.value.downcase <= char2.value.downcase)
+    end
+
+
+    def self.char_ci_gteq_impl(args, env)
+      char1, char2 = get_two_character_args("char-ci>=?", args, env)
+      Lisp::Boolean.with_value(char1.value.downcase >= char2.value.downcase)
+    end
+
+
+    def self.charp_impl(args, env)
+      raise "char->name requires a single argument, found #{args.length}" unless args.length == 1
+      char = args.car.evaluate(env)
+      Lisp::Boolean.with_value(char.character?)
+    end
+
+
+    def self.char_upcase_impl(args, env)
+      char = get_one_character_arg("char->digit", args, env)
+      find_character_for_chr(char.value.upcase)
+    end
+
+
+    def self.char_downcase_impl(args, env)
+      char = get_one_character_arg("char->digit", args, env)
+      find_character_for_chr(char.value.downcase)
+    end
+
+
+    def self.char_digit_impl(args, env)
+      char = get_one_character_arg("char->digit", args, env)
+      base = if args.length == 1
+               10
+             else
+               b = args.cadr.evaluate(env)
+               raise "Base for char->digit has to be an integer" unless b.integer?
+               raise "Base for char->digit has to be between 2 and 36" unless b.value >=2 && b.value <= 36
+               b.value
+             end
+      ch = char.value.upcase
+      value = case ch
+              when /[0-9]/
+                ch[0].ord - 48
+              when /[A-Z]/
+                10 + ch[0].ord - 65
+              else
+                -1
+              end
+      if value == -1
+        Lisp::FALSE
+      elsif value >= base
+        Lisp::FALSE
+      else
+        Lisp::Number.with_value(value)
+      end
+    end
+
+
+    def self.digit_char_impl(args, env)
+      d = args.car.evaluate(env)
+      raise "Digit value for digit->char has to be an integer" unless d.integer?
+      base = if args.length == 1
+               10
+             else
+               b = args.cadr.evaluate(env)
+               raise "Base for char->digit has to be an integer" unless b.integer?
+               raise "Base for char->digit has to be between 2 and 36" unless b.value >=2 && b.value <= 36
+               b.value
+             end
+      val = d.value
+      return Lisp::FALSE if val < 0 || val >= base 
+      find_character_for_chr((((val < 10) ? 48 : 55) + val).chr)
+    end
+
+
+    def self.char_int_impl(args, env)
+      char = get_one_character_arg("char->int", args, env)
+      Lisp::Number.with_value(char.value.ord)
+    end
+
+
+    def self.int_char_impl(args, env)
+      i = args.car.evaluate(env)
+      raise "Integer value for int->char has to be an integer" unless i.integer?
+      find_character_for_chr(i.value.chr)
+    end
+
+
+    def initialize(n)
+      @value = n
+    end
+
+
+    def set!(n)
+      @value = n
+    end
+
+
+    def character?
+      true
+    end
+
+
+    def type
+      :character
+    end
+
+
+    def to_s
+      @value
+    end
+
+
+    def to_sym
+      @value.to_sym
+    end
+
+
+    def find_charactername
+      @@character_constants.each {|k, v| return k if v == self}
+      "UNKNOWN"
+    end
+
+
+    def print_string
+      return "#\\#{find_charactername}"
+    end
+
+
+    @@character_constants = {}
+    @@character_constants["altmode"]   = Lisp::Character.new("\e")
+    @@character_constants["backnext"]  = Lisp::Character.new("\x1F")
+    @@character_constants["backspace"] = Lisp::Character.new("\b")
+    @@character_constants["call"]      = Lisp::Character.new("\x1A")
+    @@character_constants["linefeed"]  = Lisp::Character.new("\n")
+    @@character_constants["newline"]   = Lisp::Character.new("\n")
+    @@character_constants["page"]      = Lisp::Character.new("\f")
+    @@character_constants["return"]    = Lisp::Character.new("\r")
+    @@character_constants["rubout"]    = Lisp::Character.new("\x7F")
+    @@character_constants["space"]     = Lisp::Character.new(" ")
+    @@character_constants["tab"]       = Lisp::Character.new("\t")
+    @@character_constants["NUL"]       = Lisp::Character.new("\x00")
+    @@character_constants["SOH"]       = Lisp::Character.new("\x01")
+    @@character_constants["STX"]       = Lisp::Character.new("\x02")
+    @@character_constants["ETX"]       = Lisp::Character.new("\x03")
+    @@character_constants["EOT"]       = Lisp::Character.new("\x04")
+    @@character_constants["ENQ"]       = Lisp::Character.new("\x05")
+    @@character_constants["ACK"]       = Lisp::Character.new("\x06")
+    @@character_constants["BEL"]       = Lisp::Character.new("\x07")
+    @@character_constants["BS"]        = Lisp::Character.new("\x08")
+    @@character_constants["HT"]        = Lisp::Character.new("\x09")
+    @@character_constants["LF"]        = Lisp::Character.new("\x0A")
+    @@character_constants["VT"]        = Lisp::Character.new("\x0B")
+    @@character_constants["FF"]        = Lisp::Character.new("\x0C")
+    @@character_constants["CR"]        = Lisp::Character.new("\x0D")
+    @@character_constants["SO"]        = Lisp::Character.new("\x0E")
+    @@character_constants["SI"]        = Lisp::Character.new("\x0F")
+    @@character_constants["DLE"]       = Lisp::Character.new("\x10")
+    @@character_constants["DC1"]       = Lisp::Character.new("\x11")
+    @@character_constants["DC2"]       = Lisp::Character.new("\x12")
+    @@character_constants["DC3"]       = Lisp::Character.new("\x13")
+    @@character_constants["DC4"]       = Lisp::Character.new("\x14")
+    @@character_constants["NAK"]       = Lisp::Character.new("\x15")
+    @@character_constants["SYN"]       = Lisp::Character.new("\x16")
+    @@character_constants["ETB"]       = Lisp::Character.new("\x17")
+    @@character_constants["CAN"]       = Lisp::Character.new("\x18")
+    @@character_constants["EM"]        = Lisp::Character.new("\x19")
+    @@character_constants["SUB"]       = Lisp::Character.new("\x1A")
+    @@character_constants["ESC"]       = Lisp::Character.new("\x1B")
+    @@character_constants["FS"]        = Lisp::Character.new("\x1C")
+    @@character_constants["GS"]        = Lisp::Character.new("\x1D")
+    @@character_constants["RS"]        = Lisp::Character.new("\x1E")
+    @@character_constants["US"]        = Lisp::Character.new("\x1F")
+    @@character_constants["DEL"]       = Lisp::Character.new("\x7F")
+
+
+    def self.with_value(n)
+      if n.length == 1
+        ch = find_character_for_chr(n[0])
+        return ch unless ch.nil?
+        ch = self.new(n[0])
+        @@character_constants[n] = ch
+        ch
+      elsif @@character_constants.has_key?(n)
+        @@character_constants[n]
+      elsif n[0..1] == "U+"
+        find_character_for_chr(n[2..-1].to_i(16).chr)
+      else
+        raise "Invalid character name: #{n}"
+      end
+    end
+
+end
+
+end

data/lib/rubylisp/cons_cell.rb

@@ -0,0 +1,255 @@
+module Lisp
+
+  class ConsCell < Object
+    include Enumerable
+    attr_reader :car, :cdr
+
+    def self.cons(a=nil, b=nil)
+      ConsCell.new(a, b)
+    end
+
+    def initialize(car=nil, cdr=nil)
+      @car = car
+      @cdr = cdr
+    end
+
+    def value
+      self
+    end
+    
+    def set_car!(d)
+      @car = d
+    end
+
+    def lisp_object?
+      true
+    end
+    
+    def set_cdr!(d)
+      @cdr = d
+    end
+
+
+    def set_nth!(n, d)
+      c = self
+      (n-1).times {|i| c = c.cdr}
+      c.set_car!(d)
+    end
+
+    
+    def empty?
+      @car.nil? && @cdr.nil?
+    end
+
+    def string?
+      false
+    end
+
+    def character?
+      false
+    end
+
+    def number?
+      false
+    end
+
+    def positive?
+      false
+    end
+
+    def zero?
+      false
+    end
+
+    def negative?
+      false
+    end
+
+    def symbol?
+      false
+    end
+
+    def primitive?
+      false
+    end
+
+    def special?
+      false
+    end
+
+    def function?
+      false
+    end
+
+    def macro?
+      false
+    end
+
+    def pair?
+      true
+    end
+
+    def list?
+      true
+    end
+
+    def alist?
+      false
+    end
+
+    def frame?
+      false
+    end
+
+    def vector?
+      false
+    end
+    
+    def eq?(sexpr)
+      return false unless sexpr.pair?
+      (@car == sexpr.car || @car.eq?(sexpr.car)) && (@cdr == sexpr.cdr || @cdr.eq?(sexpr.cdr))
+    end
+    
+    def type
+      :pair
+    end
+
+    def to_s_helper
+      return "#{@car.to_s}" if @cdr.nil?
+      return "#{@car.to_s} . #{@cdr.to_s}" unless @cdr.pair?
+      "#{@car.to_s} #{@cdr.to_s_helper}"
+    end
+
+    def to_s
+      return "()" if self.empty?
+      return "'#{@cdr.car.to_s}" if @car.symbol? && @car.name == "quote"
+      return "(#{@car.to_s} . #{@cdr.to_s})" if !@cdr.nil? && !@cdr.pair?
+      return "(#{self.to_s_helper})"
+    end
+
+    def print_string_helper
+      @cdr.nil? ? "#{@car.print_string}" : "#{@car.print_string} #{@cdr.print_string_helper}"
+    end
+
+    def print_string
+      return "()" if self.empty?
+      return "'#{@cdr.car.print_string}" if @car.symbol? && @car.name == "quote"
+      return "(#{@car.print_string} . #{@cdr.print_string})" if !@cdr.nil? && !@cdr.pair?
+      return "(#{self.print_string_helper})"
+    end
+
+    def to_a
+      a = []
+      c = self
+      until c.nil?
+        a << c.car()
+        c = c.cdr
+      end
+      a
+    end
+
+    def each &block
+      c = self
+      if self.length > 0
+        until c.nil?
+          yield c.car 
+          c = c.cdr
+        end
+      end
+    end
+
+    def self.array_to_list(cells, tail=nil)
+      return tail if cells.empty?
+      head = ConsCell.new
+      last_cell = head
+      cells.each do |d|
+        new_cell = self.cons(d, nil)
+        last_cell.set_cdr!(new_cell)
+        last_cell = new_cell
+      end
+      last_cell.set_cdr!(tail)
+      head.cdr
+    end
+
+    def traverse(path)
+      return self if path.empty?
+      next_cell = (path[0] == ?a) ? @car : @cdr
+      return next_cell if path.length == 1
+      return nil if next_cell.nil?  || !next_cell.pair?
+      next_cell.traverse(path[1..-1])
+    end
+
+    def method_missing(name, *args, &block)
+      if name[0] == ?c && name[-1] == ?r && (name[1..-2].chars.all? {|e| "ad".include?(e)})
+        self.traverse(name[1..-2].reverse)
+      else
+        super
+      end
+    end
+
+    def nth(n)
+      c = self
+      (n-1).times {|i| c = c.cdr}
+      c.car
+    end
+
+    def nth_tail(n)
+      c = self
+      (n-1).times {|i| c = c.cdr}
+      c
+    end
+
+    def objc_object_or_nil(obj)
+      return nil unless obj.object?
+      return obj.value
+    end
+      
+
+    def evaluate(env)
+      return self if empty?
+      func = @car.evaluate(env)
+      raise "There is no function or macro named #{@car}" if func.nil?
+      func.apply_to(@cdr, env)
+    end
+
+    def evaluate_each(env)
+      result = @car.evaluate(env)
+      return result if @cdr.nil?
+      @cdr.evaluate_each(env)
+    end
+
+    def length
+      return 0 if empty?
+      return 1 if @cdr.nil?
+      return 1 + @cdr.length
+    end
+
+    def true?
+      true
+    end
+
+    def false?
+      false
+    end
+
+    def quoted
+      Lisp::ConsCell.array_to_list([Symbol.named("quote"), self])
+    end
+
+    def last
+      c = self
+      while !c.cdr.nil? && c.cdr.pair? do
+        c = c.cdr
+      end
+      c
+    end
+
+    def flatten
+      ary = to_a.collect {|s| s.list? ? s.to_a : s}
+      ConsCell.array_to_list(ary.flatten)
+    end
+    
+    
+  end
+
+end