Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Adding support for eval and all the environment creation procedures

  • Loading branch information...
commit 4e496fd3c4c6b2704c75ebd71b854173576a6d08 1 parent 8f30813
Nick Fitzgerald authored February 28, 2010

Showing 1 changed file with 103 additions and 47 deletions. Show diff stats Hide diff stats

  1. 150  scheme.adb
150  scheme.adb
@@ -431,6 +431,11 @@ procedure Scheme is
431 431
       Add_Binding_To_Frame(Var, Val, Frame);
432 432
    end;
433 433
 
  434
+   function Interaction_Environment_Proc (Arguments : Access_Object) return Access_Object is
  435
+   begin
  436
+      return The_Global_Environment;
  437
+   end;
  438
+
434 439
    function Setup_Environment return Access_Object is
435 440
       Initial_Env : Access_Object;
436 441
    begin
@@ -440,6 +445,24 @@ procedure Scheme is
440 445
       return Initial_Env;
441 446
    end;
442 447
 
  448
+   function Null_Environment_Proc (Arguments : Access_Object) return Access_Object is
  449
+   begin
  450
+      return Setup_Environment;
  451
+   end;
  452
+
  453
+   function Populate_Environment (Env : Access_Object) return Access_Object;
  454
+
  455
+   function Make_Environment return Access_Object is
  456
+      Env : Access_Object := Populate_Environment(Setup_Environment);
  457
+   begin
  458
+      return Env;
  459
+   end;
  460
+
  461
+   function Environment_Proc (Args : Access_Object) return Access_Object is
  462
+   begin
  463
+      return Make_Environment;
  464
+   end;
  465
+
443 466
    function Make_Symbol (Value : Unbounded_String) return Access_Object is
444 467
       Obj : Access_Object;
445 468
       Element : Access_Object;
@@ -801,20 +824,19 @@ procedure Scheme is
801 824
 
802 825
    function Apply_Proc (Arguments : Access_Object) return Access_Object is
803 826
    begin
804  
---        Stderr("This should never be called because it is a hack.");
805  
---        raise Constraint_Error;
  827
+      Stderr("This should never be called because it is a hack.");
  828
+      raise Constraint_Error;
806 829
       return False_Singleton;
807 830
    end;
808 831
 
809  
-   procedure Init is
810  
-      procedure Def_Primitive_Proc (Symbol : in String;
811  
-                                    Proc : in Access_Function) is
812  
-      begin
813  
-         Define_Variable(Make_Symbol(To_Unbounded_String(Symbol)),
814  
-                         Make_Primitive_Proc(Proc),
815  
-                         The_Global_Environment);
  832
+   function Eval_Proc (Arguments : Access_Object) return Access_Object is
  833
+   begin
  834
+      Stderr("This should never be called because it is a hack.");
  835
+      raise Constraint_Error;
  836
+      return False_Singleton;
  837
+   end;
816 838
 
817  
-      end;
  839
+   procedure Init is
818 840
    begin
819 841
       The_Empty_List := Alloc_Object;
820 842
       The_Empty_List.all.O_Type := Empty_List;
@@ -843,38 +865,56 @@ procedure Scheme is
843 865
       Or_Symbol := Make_Symbol(To_Unbounded_String("or"));
844 866
 
845 867
       The_Empty_Environment := The_Empty_List;
846  
-      The_Global_Environment := Setup_Environment;
847  
-
848  
-      Def_Primitive_Proc("+", Add_Proc'access);
849  
-      Def_Primitive_Proc("-", Sub_Proc'access);
850  
-      Def_Primitive_Proc("*", Multiply_Proc'access);
851  
-      Def_Primitive_Proc("quotient", Quotient_Proc'access);
852  
-      Def_Primitive_Proc("remainder", Remainder_Proc'access);
853  
-      Def_Primitive_Proc("=", Equal_Proc'access);
854  
-      Def_Primitive_Proc("<", Lt_Proc'access);
855  
-      Def_Primitive_Proc(">", Gt_Proc'access);
856  
-      Def_Primitive_Proc("null?", Is_Null_Proc'access);
857  
-      Def_Primitive_Proc("cons", Cons_Proc'access);
858  
-      Def_Primitive_Proc("car", Car_Proc'access);
859  
-      Def_Primitive_Proc("cdr", Cdr_Proc'access);
860  
-      Def_Primitive_Proc("set-car!", Set_Car_Proc'access);
861  
-      Def_Primitive_Proc("set-cdr!", Set_Cdr_Proc'access);
862  
-      Def_Primitive_Proc("list", List_Proc'access);
863  
-      Def_Primitive_Proc("boolean?", Is_Boolean_Proc'access);
864  
-      Def_Primitive_Proc("symbol?", Is_Symbol_Proc'access);
865  
-      Def_Primitive_Proc("integer?", Is_Integer_Proc'access);
866  
-      Def_Primitive_Proc("char?", Is_Char_Proc'access);
867  
-      Def_Primitive_Proc("string?", Is_String_Proc'access);
868  
-      Def_Primitive_Proc("pair?", Is_Pair_Proc'access);
869  
-      Def_Primitive_Proc("procedure?", Is_Procedure_Proc'access);
870  
-      Def_Primitive_Proc("eq?", Eq_Proc'access);
871  
-      Def_Primitive_Proc("char->integer", Char_To_Int_Proc'access);
872  
-      Def_Primitive_Proc("integer->char", Int_To_Char_Proc'access);
873  
-      Def_Primitive_Proc("number->string", Number_To_String_Proc'access);
874  
-      Def_Primitive_Proc("string->number", String_To_Number_Proc'access);
875  
-      Def_Primitive_Proc("symbol->string", Symbol_To_String_Proc'access);
876  
-      Def_Primitive_Proc("string->symbol", String_To_Symbol_Proc'access);
877  
-      Def_Primitive_Proc("apply", Apply_Proc'access);
  868
+      The_Global_Environment := Make_Environment;
  869
+   end;
  870
+
  871
+   function Populate_Environment (Env : Access_Object) return Access_Object is
  872
+      procedure Def_Primitive_Proc (Symbol : in String;
  873
+                                    Proc : in Access_Function;
  874
+                                    Env : in Access_Object) is
  875
+      begin
  876
+         Define_Variable(Make_Symbol(To_Unbounded_String(Symbol)),
  877
+                         Make_Primitive_Proc(Proc),
  878
+                         Env);
  879
+
  880
+      end;
  881
+   begin
  882
+      Def_Primitive_Proc("+", Add_Proc'Access, Env);
  883
+      Def_Primitive_Proc("-", Sub_Proc'Access, Env);
  884
+      Def_Primitive_Proc("*", Multiply_Proc'Access, Env);
  885
+      Def_Primitive_Proc("quotient", Quotient_Proc'Access, Env);
  886
+      Def_Primitive_Proc("remainder", Remainder_Proc'Access, Env);
  887
+      Def_Primitive_Proc("=", Equal_Proc'Access, Env);
  888
+      Def_Primitive_Proc("<", Lt_Proc'Access, Env);
  889
+      Def_Primitive_Proc(">", Gt_Proc'Access, Env);
  890
+      Def_Primitive_Proc("null?", Is_Null_Proc'Access, Env);
  891
+      Def_Primitive_Proc("cons", Cons_Proc'Access, Env);
  892
+      Def_Primitive_Proc("car", Car_Proc'Access, Env);
  893
+      Def_Primitive_Proc("cdr", Cdr_Proc'Access, Env);
  894
+      Def_Primitive_Proc("set-car!", Set_Car_Proc'Access, Env);
  895
+      Def_Primitive_Proc("set-cdr!", Set_Cdr_Proc'Access, Env);
  896
+      Def_Primitive_Proc("list", List_Proc'Access, Env);
  897
+      Def_Primitive_Proc("boolean?", Is_Boolean_Proc'Access, Env);
  898
+      Def_Primitive_Proc("symbol?", Is_Symbol_Proc'Access, Env);
  899
+      Def_Primitive_Proc("integer?", Is_Integer_Proc'Access, Env);
  900
+      Def_Primitive_Proc("char?", Is_Char_Proc'Access, Env);
  901
+      Def_Primitive_Proc("string?", Is_String_Proc'Access, Env);
  902
+      Def_Primitive_Proc("pair?", Is_Pair_Proc'Access, Env);
  903
+      Def_Primitive_Proc("procedure?", Is_Procedure_Proc'Access, Env);
  904
+      Def_Primitive_Proc("eq?", Eq_Proc'Access, Env);
  905
+      Def_Primitive_Proc("char->integer", Char_To_Int_Proc'Access, Env);
  906
+      Def_Primitive_Proc("integer->char", Int_To_Char_Proc'Access, Env);
  907
+      Def_Primitive_Proc("number->string", Number_To_String_Proc'Access, Env);
  908
+      Def_Primitive_Proc("string->number", String_To_Number_Proc'Access, Env);
  909
+      Def_Primitive_Proc("symbol->string", Symbol_To_String_Proc'Access, Env);
  910
+      Def_Primitive_Proc("string->symbol", String_To_Symbol_Proc'Access, Env);
  911
+      Def_Primitive_Proc("apply", Apply_Proc'Access, Env);
  912
+      Def_Primitive_Proc("interaction-environment", Interaction_Environment_Proc'Access, Env);
  913
+      Def_Primitive_Proc("null-environment", Null_Environment_Proc'Access, Env);
  914
+      Def_Primitive_Proc("environment", Environment_Proc'Access, Env);
  915
+      Def_Primitive_Proc("eval", Eval_Proc'Access, Env);
  916
+
  917
+      return Env;
878 918
    end;
879 919
 
880 920
    -- READ ----------------------------------------------------------------
@@ -1659,15 +1699,27 @@ procedure Scheme is
1659 1699
 
1660 1700
       function Is_Apply_Proc (Proc : Access_Object) return Boolean is
1661 1701
       begin
1662  
-         return Proc.all.Data.Primitive = Apply_Proc'access;
  1702
+         return Proc.all.Data.Primitive = Apply_Proc'Access;
  1703
+      end;
  1704
+
  1705
+      function Is_Eval_Proc (Proc : Access_Object) return Boolean is
  1706
+      begin
  1707
+         return Proc.all.Data.Primitive = Eval_Proc'Access;
  1708
+      end;
  1709
+
  1710
+      function Eval_Expression (Args : Access_Object) return Access_Object is
  1711
+      begin
  1712
+         return Car(Args);
  1713
+      end;
  1714
+
  1715
+      function Eval_Environment (Args : Access_Object) return Access_Object is
  1716
+      begin
  1717
+         return Cadr(Args);
1663 1718
       end;
1664 1719
 
1665 1720
    begin
1666 1721
       <<Tailcall>>
1667  
-      if Exp.all.O_Type = Symbol and then Exp.all.Data.Symbol = "_" then
1668  
-          -- Shortcut for inspecting the env.
1669  
-          return Env;
1670  
-      elsif Is_Self_Evaluating(Exp) then
  1722
+      if Is_Self_Evaluating(Exp) then
1671 1723
           return Exp;
1672 1724
       elsif Is_Variable(Exp) then
1673 1725
          return Lookup_Variable_Value(Exp, Env);
@@ -1720,6 +1772,10 @@ procedure Scheme is
1720 1772
                   --  if we find, we rewrite the AST.
1721 1773
                   Exp := Make_Application(Cadadr(Exp), Car(Cdaddr(Exp)));
1722 1774
                   goto Tailcall;
  1775
+               elsif Is_Eval_Proc(Proc) then
  1776
+                  Exp := Eval_Expression(Args);
  1777
+                  Env := Eval_Environment(Args);
  1778
+                  goto Tailcall;
1723 1779
                else
1724 1780
                   return Proc.all.Data.Primitive.all(Args);
1725 1781
                end if;

0 notes on commit 4e496fd

Please sign in to comment.
Something went wrong with that request. Please try again.