rubylisp 0.2.1 → 1.0.2

data/lib/rubylisp/prim_character.rb

@@ -0,0 +1,273 @@
+# -*- coding: utf-8 -*-
+module Lisp
+
+  class PrimCharacter
+
+    def self.register
+      Primitive.register("char->name", "1", "(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::PrimCharacter::char_name_impl(args, env)
+      end
+      
+      Primitive.register("name->char", "1", "(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::PrimCharacter::name_char_impl(args, env)
+      end
+      
+      Primitive.register("char=?", "2", "(char=? char1 char2)\n\nReturn whether char1 and char2 are the same") do |args, env|
+        Lisp::PrimCharacter::char_eq_impl(args, env)
+      end
+      
+      Primitive.register("char<?", "2", "(char<? char1 char2)\n\nReturn whether char1 is less than char2") do |args, env|
+        Lisp::PrimCharacter::char_lt_impl(args, env)
+      end
+      
+      Primitive.register("char>?", "2", "(char>? char1 char2)\n\nReturn whether char1 is greater than char2") do |args, env|
+        Lisp::PrimCharacter::char_gt_impl(args, env)
+      end
+      
+      Primitive.register("char<=?", "2", "(char<=? char1 char2)\n\nReturn whether char1 is less than or equal to char2") do |args, env|
+        Lisp::PrimCharacter::char_lteq_impl(args, env)
+      end
+      
+      Primitive.register("char>=?", "2", "(char>=? char1 char2)\n\nReturn whether char1 is greater than or equal to char2") do |args, env|
+        Lisp::PrimCharacter::char_gteq_impl(args, env)
+      end
+      
+      Primitive.register("char-ci=?", "2", "(char=? char1 char2)\n\nReturn whether char1 is equal to char2, ignoring case") do |args, env|
+        Lisp::PrimCharacter::char_ci_eq_impl(args, env)
+      end
+      
+      Primitive.register("char-ci<?", "2", "(char=? char1 char2)\n\nReturn whether char1 is less than char2, ignoring case") do |args, env|
+        Lisp::PrimCharacter::char_ci_lt_impl(args, env)
+      end
+      
+      Primitive.register("char-ci>?", "2", "(char=? char1 char2)\n\nReturn whether char1 is greater than char2, ignoring case") do |args, env|
+        Lisp::PrimCharacter::char_ci_gt_impl(args, env)
+      end
+      
+      Primitive.register("char-ci<=?", "2", "(char=? char1 char2)\n\nReturn whether char1 is less than or equal to char2, ignoring case") do |args, env|
+        Lisp::PrimCharacter::char_ci_lteq_impl(args, env)
+      end
+      
+      Primitive.register("char-ci>=?", "2", "(char=? char1 char2)\n\nReturn whether char1 is greater than orequal to char2, ignoring case") do |args, env|
+        Lisp::PrimCharacter::char_ci_gteq_impl(args, env)
+      end
+      
+      Primitive.register("char?", "1", "(char? sexpr)\n\nReturns #t if object is a character; otherwise returns #f.") do |args, env|
+        Lisp::PrimCharacter::charp_impl(args, env)
+      end
+      
+      Primitive.register("char-upcase", "1", "(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::PrimCharacter::char_upcase_impl(args, env)
+      end
+      
+      Primitive.register("char-downcase", "1", "(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::PrimCharacter::char_downcase_impl(args, env)
+      end
+      
+      Primitive.register("char->digit", "1|2", "(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::PrimCharacter::char_digit_impl(args, env)
+      end
+      
+      Primitive.register("digit->char", "1|2", "(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::PrimCharacter::digit_char_impl(args, env)
+      end
+      
+      Primitive.register("char->integer", "1", "(char->integer char)\n\nchar->integer returns the character code representation for char.") do |args, env|
+        Lisp::PrimCharacter::char_int_impl(args, env)
+      end
+      
+      Primitive.register("integer->char", "1", "(integer->char k)\n\ninteger->char returns the character whose character code representation is k.") do |args, env|
+        Lisp::PrimCharacter::int_char_impl(args, env)
+      end
+    end
+
+
+    def self.find_character_for_chr(ch)
+      Lisp::Character.character_constants.each_value {|v| return v if v.value == ch}
+      return Lisp::Character.character_constants[ch] = Lisp::Character.new(ch)
+    end
+
+
+    def self.find_character_for_name(n)
+      return Lisp::Character.character_constants[n] if Lisp::Character.character_constants.has_key?(n)
+      if n.length == 1
+        ch = self.new(n[0])
+       return Lisp::Character.character_constants[n] = ch
+      end
+      nil
+    end
+
+
+    def self.char_name_impl(args, env)
+      char = args.car
+      return Lisp::Debug.process_error("char->name requires a character argument", env) unless char.character?
+      kv = Lisp::Character.character_constants.rassoc(char)
+      return Lisp::String.with_value(kv[0]) unless kv.nil?
+      return Lisp::Debug.process_error("char->name was passed an invalid character", env)
+    end
+
+
+    def self.name_char_impl(args, env)
+      name = args.car
+      return Lisp::Debug.process_error("name->char requires a string argument", env) unless name.string?
+      ch = find_character_for_name(name.value)
+      return ch unless ch.nil?
+      return Lisp::Debug.process_error("There is no character with the name #{name}", env)
+    end
+
+
+    def self.get_one_character_arg(func, args, env)
+      char1 = args.car
+      return Lisp::Debug.process_error("#{func} requires a character argument, found #{char1}", env) unless char1.character?
+      return char1
+    end
+
+
+    def self.get_two_character_args(func, args, env)
+      char1 = args.car
+      return Lisp::Debug.process_error("#{func} requires character arguments, found #{char1}", env) unless char1.character?
+      char2 = args.cadr
+      return Lisp::Debug.process_error("#{func} requires character arguments, found #{char2}", env) 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)
+      char = args.car
+      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
+               return Lisp::Debug.process_error("Base for char->digit has to be an integer", env) unless b.integer?
+               return Lisp::Debug.process_error("Base for char->digit has to be between 2 and 36", env) 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
+      return Lisp::Debug.process_error("Digit value for digit->char has to be an integer", env) unless d.integer?
+      base = if args.length == 1
+               10
+             else
+               b = args.cadr
+               return Lisp::Debug.process_error("Base for char->digit has to be an integer", env) unless b.integer?
+               return Lisp::Debug.process_error("Base for char->digit has to be between 2 and 36", env) 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
+      return Lisp::Debug.process_error("Integer value for int->char has to be an integer", env) unless i.integer?
+      find_character_for_chr(i.value.chr)
+    end
+
+  end
+
+end

data/lib/rubylisp/{ffi_class.rb → prim_class_object.rb}

@@ -1,41 +1,38 @@
 # -*- coding: utf-8 -*-
 module Lisp
 
-  class ClassObject < Atom
+  class PrimClassObject
 
     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)
+      Primitive.register("extend", "2", "(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::PrimClassObject::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)
+      Primitive.register("add-method", "3", "(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::PrimClassObject::add_method_impl(args, env)
       end
       
       Primitive.register("add-static-method", "Not Implemented.") do |args, env|
-        Lisp::ClassObject::add_static_method_impl(args, env)
+        Lisp::PrimClassObject::add_static_method_impl(args, env)
       end
       
       Primitive.register("super", "Not implemented.") do |args, env|
-        Lisp::ClassObject::super_impl(args, env)
+        Lisp::PrimClassObject::super_impl(args, env)
       end
       
     end
 
 
     def self.extend_impl(args, env)
-      return Lisp::Debug.process_error("'extend' requires 2 arguments.", env) if args.length != 2
-
-      class_name = args.car.evaluate(env)
+      class_name = args.car
       return Lisp::Debug.process_error("'extend' requires a name as it's first argument.", env) unless class_name.string? || class_name.symbol?
       super_class = Object.const_get(class_name.to_s)
       return Lisp::Debug.process_error("'extend' requires the name of an existing class as it's first argument.", env) if super_class.nil?
 
-      new_class_name = args.cadr.evaluate(env)
+      new_class_name = args.cadr
       return Lisp::Debug.process_error("'extend' requires a name  as it's second argument.", env) unless new_class_name.string? || new_class_name.symbol?
       new_class = Class.new(super_class)
-      return Lisp::Debug.process_error("'extend' requires the name of a new (i.e. nonexistant) class as it's second argument.", env) if Object.const_defined?(new_class_name.to_s)
-
+      return Lisp::Debug.process_error("'extend' requires the name of a new (i.e. nonexistant) class as it's second argument.", env) if Lisp.const_defined?(new_class_name.to_s)
       Object.const_set(new_class_name.to_s, new_class)
       ClassObject.with_class(new_class)
     end
@@ -77,23 +74,22 @@ module Lisp
 
     
     def self.add_method_impl(args, env)
-      return Lisp::Debug.process_error("'add-method' requires 3 arguments.", env) if args.length != 3
-      class_name = args.car.evaluate(env)
+      class_name = args.car
       return Lisp::Debug.process_error("'add-method' requires a class name as it's first argument.", env) unless class_name.string? || class_name.symbol?
       target_class = Object.const_get(class_name.to_s)
       return Lisp::Debug.process_error("'add-method' requires the name of an existing class.", env) if target_class.nil?
 
-      method_name = args.cadr.evaluate(env)
+      method_name = args.cadr
       return Lisp::Debug.process_error("'add-method' requires a method name as it's second argument.", env) unless class_name.string? || class_name.symbol?
 
-      body = args.caddr.evaluate(env)
+      body = args.caddr
       return Lisp::Debug.process_error("'add-method' requires a function as it's third argument.", env) unless body.function?
       
       target_class.send(:define_method, method_name.to_s) do |*args|
-        local_env = Lisp::EnvironmentFrame.extending(env)
+        local_env = Lisp::EnvironmentFrame.extending(env, "#{class_name.to_s}-#{method_name.to_s}")
         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), local_env), local_env)
+        Lisp::PrimClassObject.convert_to_ruby(body.apply_to(Lisp::ConsCell.array_to_list(processed_args), local_env), local_env)
       end
       Lisp::String.with_value("OK")
     end
@@ -108,55 +104,6 @@ module Lisp
       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/prim_environment.rb

@@ -0,0 +1,203 @@
+module Lisp
+
+  class PrimEnvironment
+
+    def self.register
+      Primitive.register("environment?", "1") {|args, env|  Lisp::PrimEnvironment::environmentp_impl(args, env)}
+	  Primitive.register("environment-has-parent?", "1") {|args, env|  Lisp::PrimEnvironment::environment_parentp_impl(args, env) }
+	  Primitive.register("environment-bound-names", "1") {|args, env|  Lisp::PrimEnvironment::environment_bound_names_impl(args, env) }
+	  Primitive.register("environment-macro-names", "1") {|args, env|  Lisp::PrimEnvironment::environment_macro_names_impl(args, env) }
+	  Primitive.register("environment-bindings", "1") {|args, env|  Lisp::PrimEnvironment::environment_bindings_impl(args, env) }
+	  Primitive.register("environment-reference-type", "2") {|args, env|  Lisp::PrimEnvironment::environment_reference_type_impl(args, env) }
+	  Primitive.register("environment-bound?", "2") {|args, env|  Lisp::PrimEnvironment::environment_boundp_impl(args, env) }
+	  Primitive.register("environment-assigned?", "2") {|args, env|  Lisp::PrimEnvironment::environment_assignedp_impl(args, env) }
+	  Primitive.register("environment-lookup", "2") {|args, env|  Lisp::PrimEnvironment::environment_lookup_impl(args, env) }
+	  Primitive.register("environment-lookup-macro", "2") {|args, env|  Lisp::PrimEnvironment::environment_lookup_macro_impl(args, env) }
+	  Primitive.register("environment-assignable?", "2") {|args, env|  Lisp::PrimEnvironment::environment_assignablep_impl(args, env) }
+	  Primitive.register("environment-assign!", "3") {|args, env|  Lisp::PrimEnvironment::environment_assign_bang_impl(args, env) }
+	  Primitive.register("environment-definable?", "2") {|args, env|  Lisp::PrimEnvironment::environment_definablep_impl(args, env) }
+	  Primitive.register("environment-define", "3") {|args, env|  Lisp::PrimEnvironment::environment_define_impl(args, env) }
+	  Primitive.register("the-environment", "0") {|args, env|  Lisp::PrimEnvironment::the_environment_impl(args, env) }
+	  Primitive.register("procedure-environment", "1") {|args, env|  Lisp::PrimEnvironment::procedure_environment_impl(args, env) }
+	  Primitive.register("environment-parent", "1") {|args, env|  Lisp::PrimEnvironment::environment_parent_impl(args, env) }
+	  Primitive.register("system-global-environment", "0") {|args, env|  Lisp::PrimEnvironment::system_global_environment_impl(args, env) }
+	  Primitive.register("make-top-level-environment", "1|2|3") {|args, env|  Lisp::PrimEnvironment::make_top_level_environment_impl(args, env) }
+	  Primitive.register("find-top-level-environment", "1") {|args, env|  Lisp::PrimEnvironment::find_top_level_environment_impl(args, env) }
+    end
+
+
+    def self.environmentp_impl(args, env)
+      Lisp::Boolean.with_value(args.car.environment?)
+    end
+
+    
+	def self.environment_parentp_impl(args, env)
+      return Lisp::Debug.process_error("environment-has-parent? requires an environment for it's argument, received: #{args.car}", env) unless args.car.environment?
+      Lisp::Boolean.with_value(!args.car.value.parent.nil?)
+    end
+
+    
+	def self.environment_bound_names_impl(args, env)
+      return Lisp::Debug.process_error("environment-bound-names requires an environment for it's argument, received: #{args.car}", env) unless args.car.environment?
+      e = args.car.value
+      Lisp::ConsCell.array_to_list(e.bound_names)
+    end
+    
+    
+	def self.environment_macro_names_impl(args, env)
+      return Lisp::Debug.process_error("environment-macro-names requires an environment for it's argument, received: #{args.car}", env) unless args.car.environment?
+      e = args.car.value
+      Lisp::ConsCell.array_to_list(e.bound_values.select {|v| v.macro?})
+    end
+    
+    
+	def self.environment_bindings_impl(args, env)
+      return Lisp::Debug.process_error("environment-bindings requires an environment for it's argument, received: #{args.car}", env) unless args.car.environment?
+      Lisp::ConsCell.array_to_list(args.car.value.bindings.map { |b| Lisp::ConsCell.array_to_list(b.value.nil? ? [b.symbol] : [b.symbol, b.value]) })
+    end
+    
+    
+	def self.environment_reference_type_impl(args, env)
+      return Lisp::Debug.process_error("environment-reference-type requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
+      return Lisp::Debug.process_error("environment-reference-type requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
+      b = args.car.value.binding_for(args.cadr.value)
+      return Lisp::Symbol.named("unbound") if b.nil?
+      return Lisp::Symbol.named("unassigned") if b.value.nil?
+      return Lisp::Symbol.named("macro") if b.value.binding?
+      Lisp::Symbol.named("normal")
+    end
+
+    
+	def self.environment_boundp_impl(args, env)
+      return Lisp::Debug.process_error("environment-bound? requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
+      return Lisp::Debug.process_error("environment-bound? requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
+      Lisp::Boolean.with_value(args.car.value.name_bound_locally?(args.cadr.name)) 
+    end
+
+    
+	def self.environment_assignedp_impl(args, env)
+      return Lisp::Debug.process_error("environment-assigned? requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
+      return Lisp::Debug.process_error("environment-assigned? requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
+      return Lisp::Debug.process_error("environment-assigned?: #{args.cadr.to_s} is unbound", env) unless args.car.value.name_bound_locally?(args.cadr.name)
+      b = args.car.value.local_binding_for(args.cadr)
+      return Lisp::Debug.process_error("environment-assigned?: #{args.cadr.to_s} is bound to a macro", env) if b.value.macro?     
+      Lisp::Boolean.with_value(!b.value.nil?) 
+    end
+
+    
+	def self.environment_lookup_impl(args, env)
+      return Lisp::Debug.process_error("environment-lookup requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
+      return Lisp::Debug.process_error("environment-lookup requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
+      return Lisp::Debug.process_error("environment-lookup: #{args.cadr.to_s} is unbound", env) unless args.car.value.name_bound_locally?(args.cadr.name)
+      b = args.car.value.local_binding_for(args.cadr)
+      return Lisp::Debug.process_error("environment-lookup: #{args.cadr.to_s} is unassigned", env) if b.value.nil?
+      return Lisp::Debug.process_error("environment-lookup: #{args.cadr.to_s} is bound to a macro", env) if b.value.macro?
+      b.value
+    end
+
+    
+	def self.environment_lookup_macro_impl(args, env)
+      return Lisp::Debug.process_error("environment-lookup-macro requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
+      return Lisp::Debug.process_error("environment-lookup-macro requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
+      return Lisp::Debug.process_error("environment-lookup-macro: #{args.cadr.to_s} is unbound", env) unless args.car.value.name_bound_locally?(args.cadr)
+      b = args.car.value.local_binding_for(args.cadr)
+      return Lisp::Debug.process_error("environment-lookup-macro: #{args.cadr.to_s} is unassigned", env) if b.value.nil?
+      return Lisp::Debug.process_error("environment-lookup-macro: #{args.cadr.to_s} is bound to a macro", env) if b.value.macro?
+      b.value
+    end
+
+    
+	def self.environment_assignablep_impl(args, env)
+      return Lisp::Debug.process_error("environment-assignable? requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
+      return Lisp::Debug.process_error("environment-assignable? requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
+      local_env = args.car.value
+      binding = local_env.binding_for(args.cadr)
+      Lisp::Boolean.with_value(!binding.nil?)
+    end
+    
+    
+	def self.environment_assign_bang_impl_impl(args, env)
+      return Lisp::Debug.process_error("environment-assign! requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
+      return Lisp::Debug.process_error("environment-assign! requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
+      local_env = args.car.value
+      binding = local_env.binding_for(args.cadr)
+      binding.value = args.caddr unless binding.nil?
+    end
+    
+    
+	def self.environment_definablep_impl(args, env)
+      return Lisp::Debug.process_error("environment-definable?requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
+      return Lisp::Debug.process_error("environment-definable? requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
+      Lisp::TRUE
+    end
+    
+    
+	def self.environment_define_impl(args, env)
+      return Lisp::Debug.process_error("environment-define requires an environment for it's first argument, received: #{args.car}", env) unless args.car.environment?
+      return Lisp::Debug.process_error("environment-define requires a symbol for it's second argument, received: #{args.cadr}", env) unless args.cadr.symbol?
+      args.car.value.bind_locally(args.cadr, args.caddr)
+      Lisp::TRUE
+    end
+
+    
+	def self.the_environment_impl(args, env)
+      Lisp::Environment.with_value(env) if env == Lisp.EnvironmentFrame.global || env.parent == Lisp.EnvironmentFrame.global
+      Lisp::Debug.process_error("the-environment can only be called from a top-level environment", env)
+    end
+
+    
+	def self.procedure_environment_impl(args, env)
+      Lisp::Debug.process_error("procedure-environment requires a user written function as it's argument", env) unless args.car.function?
+      Lisp::Environment.with_value(args.car.env)
+    end
+
+    
+	def self.environment_parent_impl(args, env)
+      return Lisp::Debug.process_error("environment-parent requires an environment for it's argument, received: #{args.car}", env) unless args.car.environment?
+      e = args.car.value
+      e.parent.nil? ? nil : Lisp::Environment.with_value(e.parent)
+    end
+
+    
+	def self.system_global_environment_impl(args, env)
+      Lisp::Environment.with_value(Lisp::EnvironmentFrame.global)
+    end
+    
+    
+	def self.make_top_level_environment_impl(args, env)
+      if args.car.string?
+        name = args.car.value
+        args = args.cdr
+      else
+        name = "anonymous top level"
+      end
+
+      new_env = Lisp::EnvironmentFrame.extending(Lisp::EnvironmentFrame.global, name)
+      if args.length == 1
+        return Lisp::Debug.process_error("make-top-level-environment expects binding names to be a list", env) unless args.car.list?
+        args.to_a.map do |a|
+          return Lisp::Debug.process_error("make-top-level-environment expects each binding name to be a symbol", env) unless a.car.symbol?
+          new_env.bind_locally_to(a.car, nil)
+        end
+      elsif args.length == 2
+        return Lisp::Debug.process_error("make-top-level-environment expects binding names to be a list", env) unless args.car.list?
+        return Lisp::Debug.process_error("make-top-level-environment expects binding values to be a list", env) unless args.cadr.list?
+        return Lisp::Debug.process_error("make-top-level-environment expects binding name and value lists to be the same length", env) if args.car.length != args.cadr.length
+        args.car.zip(args.cadr).map do |name, value|
+          return Lisp::Debug.process_error("make-top-level-environment expects each binding name to be a symbol", env) unless name.symbol?
+          new_env.bind_locally_to(name, value)
+        end
+      end
+      return Lisp::Environment.with_value(new_env)
+    end
+
+    
+	def self.find_top_level_environment_impl(args, env)
+      return Lisp::Debug.process_error("find-top-level-environment requires a symbol or sting environment name, received: #{args.cadr}", env) unless args.cadr.symbol? || args.cadr.string
+      e = Lisp::TopLevelEnvironments[args.car.to_s]
+      return e.nil? ? nil : Lisp::Environment.with_value(e)
+    end
+
+  end
+
+end