diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index acc1208..4a54c69 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -420,7 +420,8 @@ r: object_pointer := get_frame_result(c); rw: object_word; for rw'address use r'address; begin -ada.text_io.put ("Frame" & object_word'image(f) & " PUSH CONTINUATION CURRENT RESULT" & object_word'image(rw) & " ----> "); +ada.text_io.put_line ("Frame" & object_word'image(f) & " " & Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); +ada.text_io.put (" CURRENT RESULT "); print (interp, r); end; @@ -435,7 +436,7 @@ for w'address use c'address; f: object_word; for f'address use interp.stack'address; begin -ada.text_io.put (" PUSH CONTINUATION"); +ada.text_io.put (" PUSH CONTINUATION "); ada.text_io.put (object_word'image(w) & " "); print (interp, c); end; @@ -457,7 +458,8 @@ for w'address use func'address; f: object_word; for f'address use interp.stack'address; begin -ada.text_io.put ("Frame" & object_word'image(f) & " POPING APPLY CONTINUATION -----> "); +ada.text_io.put_line ("Frame" & object_word'image(f) & " " & Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); +ada.text_io.put (" POPPING ... APPLY CONTINUATION -->> "); ada.text_io.put (object_word'image(w) & " "); end; Print (Interp, Args); @@ -483,7 +485,7 @@ ada.text_io.put (" CURRENT RESULT " ); print (interp, get_Frame_result(interp.stack)); ada.text_io.put (" CURRENT OPERAND " ); print (interp, get_Frame_operand(interp.stack)); -ada.text_io.put_line (" CURRENT OPCODE" & opcode_type'image(get_Frame_opcode(interp.stack))); +ada.text_io.put_line (" CURRENT OPCODE " & opcode_type'image(get_Frame_opcode(interp.stack))); end; @@ -533,7 +535,8 @@ declare w: object_word; for w'address use interp.stack'address; begin -ada.text_io.put ("Frame" & object_word'image(w) & " OPERAND TO APPLY => "); +ada.text_io.put_line ("Frame" & object_word'image(w) & " " & Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); +ada.text_io.put (" OPERAND TO APPLY => "); print (Interp, Operand); ada.text_io.put (" CURRENT RESULT => "); print (Interp, get_frame_result(interp.stack)); diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 890fc3a..4749511 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -198,7 +198,8 @@ declare w: object_word; for w'address use interp.stack'address; begin -ada.text_io.put ("Frame " & object_word'image(w) & " EVAL-GROUP RESULT "); +ada.text_io.put_line ("Frame" & object_word'image(w) & " " & Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); +ada.text_io.put (" EVAL-GROUP RESULT "); print (Interp, R); end; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index c7230b7..7550b23 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -93,32 +93,35 @@ package body H2.Scheme is subtype Moved_Object_Record is Object_Record (Moved_Object, 0); - subtype Opcode_Type is Object_Integer range 0 .. 22; - 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_Finish_And_Syntax: constant Opcode_Type := Opcode_Type'(3); - Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(4); - Opcode_Finish_If_Syntax: constant Opcode_Type := Opcode_Type'(5); - Opcode_Finish_Or_Syntax: constant Opcode_Type := Opcode_Type'(6); + type Opcode_Type is ( + Opcode_Exit, + Opcode_Evaluate_Result, + Opcode_Evaluate_Object, + Opcode_Finish_And_Syntax, + Opcode_Finish_Define_Symbol, + Opcode_Finish_If_Syntax, + Opcode_Finish_Or_Syntax, + + Opcode_Grouped_Call, -- (begin ...), closure apply, let body + Opcode_Grouped_Call_Finish, + Opcode_Let_Binding, + Opcode_Letast_Binding, + Opcode_Letast_Binding_Finish, + Opcode_Let_Evaluation, + Opcode_Let_Finish, + Opcode_Procedure_Call, + Opcode_Set_Finish, + + Opcode_Apply, + Opcode_Read_Object, + Opcode_Read_List, + Opcode_Read_List_Cdr, + Opcode_Read_List_End, + Opcode_Close_List, + Opcode_Close_Quote + ); + for Opcode_Type'Size use Object_Integer'Size; - Opcode_Grouped_Call: constant Opcode_Type := Opcode_Type'(7); -- (begin ...), closure apply, let body - Opcode_Grouped_Call_Finish: constant Opcode_Type := Opcode_Type'(8); - Opcode_Let_Binding: constant Opcode_Type := Opcode_Type'(9); - Opcode_Letast_Binding: constant Opcode_Type := Opcode_Type'(10); - Opcode_Letast_Binding_Finish:constant Opcode_Type := Opcode_Type'(11); - Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(12); - Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(13); - Opcode_Procedure_Call: constant Opcode_Type := Opcode_Type'(14); - Opcode_Set_Finish: constant Opcode_Type := Opcode_Type'(15); - - Opcode_Apply: constant Opcode_Type := Opcode_Type'(16); - Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(17); - Opcode_Read_List: constant Opcode_Type := Opcode_Type'(18); - Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(19); - Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(20); - Opcode_Close_List: constant Opcode_Type := Opcode_Type'(21); - Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(22); ----------------------------------------------------------------------------- -- COMMON OBJECTS @@ -276,12 +279,12 @@ package body H2.Scheme is function Pointer_To_Word is new Ada.Unchecked_Conversion (Object_Pointer, Object_Word); --function Pointer_To_Word (Pointer: in Object_Pointer) return Object_Word is + -- pragma Inline (Pointer_To_Word); -- Word: Object_Word; -- for Word'Address use Pointer'Address; --begin -- return Word; --end Pointer_To_Word; - pragma Inline (Pointer_To_Word); function Pointer_To_Integer (Pointer: in Object_Pointer) return Object_Integer is Word: Object_Word := Pointer_To_Word (Pointer); @@ -396,6 +399,24 @@ package body H2.Scheme is return Integer_To_Pointer(V); end String_To_Integer_Pointer; + ----------------------------------------------------------------------------- + -- MORE CONVERSIONS + ----------------------------------------------------------------------------- + --function Pointer_To_Opcode (Pointer: in Object_Pointer) return Opcode_Type renames Pointer_To_Integer; + --function Opcode_To_Pointer (Opcode: in Opcode_Type) return Object_Pointer renames Integer_To_Pointer; + + function Pointer_To_Opcode (Pointer: in Object_Pointer) return Opcode_Type is + pragma Inline (Pointer_To_Opcode); + begin + return Opcode_Type'Val(Pointer_To_Integer(Pointer)); + end Pointer_To_Opcode; + + function Opcode_To_Pointer (Opcode: in Opcode_Type) return Object_Pointer is + pragma Inline (Opcode_To_Pointer); + begin + return Integer_To_Pointer(Opcode_Type'Pos(Opcode)); + end Opcode_To_Pointer; + ----------------------------------------------------------------------------- -- MEMORY MANAGEMENT ----------------------------------------------------------------------------- @@ -1246,15 +1267,15 @@ Ada.Text_IO.Put_Line ("Make_String..."); pragma Inline (Get_Frame_Opcode); pragma Assert (Is_Frame(Frame)); begin - return Pointer_To_Integer(Frame.Pointer_Slot(Frame_Opcode_Index)); + return Pointer_To_Opcode(Frame.Pointer_Slot(Frame_Opcode_Index)); end Get_Frame_Opcode; procedure Set_Frame_Opcode (Frame: in Object_Pointer; - OpcodE: in Opcode_Type) is + Opcode: in Opcode_Type) is pragma Inline (Set_Frame_Opcode); pragma Assert (Is_Frame(Frame)); begin - Frame.Pointer_Slot(Frame_Opcode_Index) := Integer_To_Pointer(Opcode); + Frame.Pointer_Slot(Frame_Opcode_Index) := Opcode_To_Pointer(Opcode); end Set_Frame_Opcode; function Get_Frame_Operand (Frame: in Object_Pointer) return Object_Pointer is @@ -1791,7 +1812,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Interp.Mark := Make_Mark(Interp.Self, 0); -- to indicate the end of cons evaluation Interp.Root_Environment := Make_Environment(Interp.Self, Nil_Pointer); - Interp.Root_Frame := Make_Frame(Interp.Self, Nil_Pointer, Integer_To_Pointer(Opcode_Exit), Nil_Pointer, Interp.Root_Environment); + Interp.Root_Frame := Make_Frame(Interp.Self, Nil_Pointer, Opcode_To_Pointer(Opcode_Exit), Nil_Pointer, Interp.Root_Environment); Interp.Stack := Interp.Root_Frame; Make_Syntax_Objects; @@ -2087,8 +2108,6 @@ end if; Ada.Text_IO.New_Line; end Print; - function Pointer_To_Opcode (Pointer: in Object_Pointer) return Opcode_Type renames Pointer_To_Integer; - function Opcode_To_Pointer (Opcode: in Opcode_Type) return Object_Pointer renames Integer_To_Pointer; procedure Push_Frame (Interp: in out Interpreter_Record; Opcode: in Opcode_Type;