implemented set!

This commit is contained in:
2014-01-20 15:47:08 +00:00
parent 75863951ef
commit 4197fa41ff
4 changed files with 149 additions and 32 deletions

View File

@ -80,20 +80,21 @@ package body H2.Scheme is
subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
subtype Opcode_Type is Object_Integer range 0 .. 12;
subtype Opcode_Type is Object_Integer range 0 .. 13;
Opcode_Exit: constant Opcode_Type := Opcode_Type'(0);
Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1);
Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(2);
Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply
Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(4);
Opcode_Finish_If: constant Opcode_Type := Opcode_Type'(5);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(6);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(7);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(8);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(9);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(10);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(11);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(12);
Opcode_Finish_Set: constant Opcode_Type := Opcode_Type'(6);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(7);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(8);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(9);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(10);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(11);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(12);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(13);
-----------------------------------------------------------------------------
-- COMMON OBJECTS
@ -990,6 +991,17 @@ end if;
Source.Pointer_Slot(Cons_Cdr_Index) := Value;
end Set_Cdr;
function Get_Last_Cdr (Source: in Object_Pointer) return Object_Pointer is
pragma Assert (Is_Cons(Source));
Ptr: Object_Pointer := Source;
begin
loop
Ptr := Get_Cdr(Ptr);
exit when not Is_Cons(Ptr);
end loop;
return Ptr;
end Get_Last_Cdr;
function Reverse_Cons (Source: in Object_Pointer;
Last_Cdr: in Object_Pointer := Nil_Pointer) return Object_Pointer is
pragma Assert (Is_Cons(Source));
@ -1151,7 +1163,24 @@ Ada.Text_IO.Put_Line ("Make_String...");
return null; -- not found. note that it's not Nil_Pointer.
end Find_In_Environment_List;
procedure Set_Environment (Interp: in out Interpreter_Record;
function Set_Environment (Interp: access Interpreter_Record;
Key: in Object_Pointer;
Value: in Object_Pointer) return Object_Pointer is
Arr: Object_Pointer;
begin
pragma Assert (Is_Symbol(Key));
Arr := Find_In_Environment_List(Interp, Get_Car(Interp.Environment), Key);
if Arr = null then
return null;
else
-- overwrite an existing pair
Arr.Pointer_Slot(2) := Value;
return Value;
end if;
end Set_Environment;
procedure Put_Environment (Interp: in out Interpreter_Record;
Key: in Object_Pointer;
Value: in Object_Pointer) is
Arr: Object_Pointer;
@ -1182,8 +1211,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- overwrite an existing pair
Arr.Pointer_Slot(2) := Value;
end if;
end Set_Environment;
end Put_Environment;
function Get_Environment (Interp: access Interpreter_Record;
Key: in Object_Pointer) return Object_Pointer is
@ -1261,7 +1289,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- Link it to the top environement
pragma Assert (Interp.Environment = Interp.Root_Environment);
pragma Assert (Get_Environment (Interp.Self, Symbol) = null);
Set_Environment (Interp.all, Symbol, Proc);
Put_Environment (Interp.all, Symbol, Proc);
Pop_Tops (Interp.all, 2);
return Proc;