diff --git a/cmd/scheme.adb b/cmd/scheme.adb index bc53eb0..e42cacc 100644 --- a/cmd/scheme.adb +++ b/cmd/scheme.adb @@ -8,12 +8,18 @@ procedure scheme is Pool: aliased Storage.Global_Pool; SI: S.Interpreter_Record; + I: S.Object_Pointer; + O: S.Object_Pointer; begin Ada.Text_Io.Put_Line (S.Object_Word'Image(S.Object_Pointer_Bytes)); S.Open (SI, 2_000_000, Pool'Unchecked_Access); --S.Open (SI, null); - S.Evaluate (SI); +S.Make_Test_Object (SI, I); + S.Evaluate (SI, I, O); +S.Print (SI, I); +Ada.Text_IO.Put_Line ("-------------------------------------------"); +S.Print (SI, O); S.Close (SI); declare diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 07f7685..c61b4fd 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -20,6 +20,14 @@ package body H2.Scheme is type Thin_Memory_Element_Array_Pointer is access all Thin_Memory_Element_Array; for Thin_Memory_Element_Array_Pointer'Size use Object_Pointer_Bits; + subtype Opcode_Type is Object_Integer range 0 .. 5; + Opcode_Exit: constant Opcode_Type := Opcode_Type'(0); + Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(1); + Opcode_Evaluate_Argument: constant Opcode_Type := Opcode_Type'(2); + Opcode_Evaluate_Syntax: constant Opcode_Type := Opcode_Type'(3); + Opcode_Evaluate_Procedure: constant Opcode_Type := Opcode_Type'(4); + Opcode_Apply: constant Opcode_Type := Opcode_Type'(5); + ---------------------------------------------------------------------------------- -- COMMON OBJECTS ---------------------------------------------------------------------------------- @@ -27,10 +35,19 @@ package body H2.Scheme is Cons_Car_Index: constant Pointer_Object_Size := 1; Cons_Cdr_Index: constant Pointer_Object_Size := 2; - Frame_Object_Size: constant Pointer_Object_Size := 3; + Frame_Object_Size: constant Pointer_Object_Size := 5; Frame_Stack_Index: constant Pointer_Object_Size := 1; Frame_Opcode_Index: constant Pointer_Object_Size := 2; Frame_Operand_Index: constant Pointer_Object_Size := 3; + Frame_Environment_Index: constant Pointer_Object_Size := 4; + Frame_Return_Index: constant Pointer_Object_Size := 5; + + Procedure_Object_Size: constant Pointer_Object_Size := 1; + Procedure_Opcode_Index: constant Pointer_Object_Size := 1; + + Closure_Object_Size: constant Pointer_Object_Size := 2; + Closure_Code_Index: constant Pointer_Object_Size := 1; + Closure_Environment_Index: constant Pointer_Object_Size := 2; procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Memory_Element_Pointer); procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Object_Pointer); @@ -293,8 +310,15 @@ package body H2.Scheme is procedure Print_Object_Pointer (Msg: in Object_String; Source: in Object_Pointer) is W: Object_Word; for W'Address use Source'Address; + + Ptr_Type: Object_Pointer_Type; begin - if Is_Special_Pointer (Source) then + Ptr_Type := Get_Pointer_Type(Source); + if Ptr_Type = Object_Pointer_Type_Character then + Text_IO.Put_Line (Msg & Object_Character'Image(Pointer_To_Character(Source))); + elsif Ptr_Type = Object_Pointer_Type_Integer then + Text_IO.Put_Line (Msg & Object_Integer'Image(Pointer_To_Integer(Source))); + elsif Is_Special_Pointer (Source) then Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W)); elsif Source.Kind = Character_Object then Text_IO.Put (Msg & " at " & Object_Word'Image(W) & " at " & Object_Kind'Image(Source.Kind) & " size " & Object_Size'Image(Source.Size) & " - "); @@ -748,6 +772,40 @@ Text_IO.Put_Line (">>> [GC DONE]"); Source.Tag = Cons_Object; end Is_Cons; + function Get_Car (Source: in Object_Pointer) return Object_Pointer is + pragma Inline (Get_Car); + begin + pragma Assert (Is_Cons (Source)); + pragma Assert (Source.Size = Cons_Object_Size); + return Source.Pointer_Slot(Cons_Car_Index); + end Get_Car; + + procedure Set_Car (Source: in out Object_Pointer; + Value: in Object_Pointer) is + pragma Inline (Set_Car); + begin + pragma Assert (Is_Cons (Source)); + pragma Assert (Source.Size = Cons_Object_Size); + Source.Pointer_Slot(Cons_Car_Index) := Value; + end Set_Car; + + function Get_Cdr (Source: in Object_Pointer) return Object_Pointer is + pragma Inline (Get_Cdr); + begin + pragma Assert (Is_Cons (Source)); + pragma Assert (Source.Size = Cons_Object_Size); + return Source.Pointer_Slot(Cons_Cdr_Index); + end Get_Cdr; + + procedure Set_Cdr (Source: in out Object_Pointer; + Value: in Object_Pointer) is + pragma Inline (Set_Cdr); + begin + pragma Assert (Is_Cons (Source)); + pragma Assert (Source.Size = Cons_Object_Size); + Source.Pointer_Slot(Cons_Cdr_Index) := Value; + end Set_Cdr; + procedure Make_Cons (Interp: in out Interpreter_Record; Car: in Object_Pointer; Cdr: in Object_Pointer; @@ -760,6 +818,17 @@ Text_IO.Put_Line (">>> [GC DONE]"); Print_Object_Pointer ("Make_Cons Result - ", Result); end Make_Cons; + function Make_Cons (Interp: access Interpreter_Record; + Car: in Object_Pointer; + Cdr: in Object_Pointer) return Object_Pointer is + Result: Object_Pointer; + begin + Make_Cons (Interp.all, Car, Cdr, Result); + return Result; + end Make_Cons; + + ---------------------------------------------------------------------------------- + procedure Make_String (Interp: in out Interpreter_Record; Source: in Object_String; Result: out Object_Pointer) is @@ -769,6 +838,13 @@ Print_Object_Pointer ("Make_Cons Result - ", Result); Print_Object_Pointer ("Make_String Result - " & Source, Result); end Make_String; + function Is_Symbol (Source: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_Symbol); + begin + return Is_Normal_Pointer (Source) and then + Source.Tag = Symbol_Object; + end Is_Symbol; + procedure Make_Symbol (Interp: in out Interpreter_Record; Source: in Object_String; Result: out Object_Pointer) is @@ -811,49 +887,6 @@ Text_IO.Put_Line ("Creating a symbol .. " & Source); Print_Object_Pointer ("Make_Symbol Result - " & Source, Result); end Make_Symbol; - - procedure Make_Syntax (Interp: in out Interpreter_Record; - Scode: in Syntax_Code; - Name: in Object_String; - Result: out Object_Pointer) is - begin - Make_Symbol (Interp, Name, Result); - Result.Flags := Result.Flags or Syntax_Object; - Result.Scode := Scode; -Text_IO.Put ("Creating Syntax Symbol "); -Put_String (To_Thin_String_Pointer (Result)); - end Make_Syntax; - - procedure Make_Procedure (Interp: in out Interpreter_Record; - Name: in Object_String; - Result: out Object_Pointer) is - begin - null; - end Make_Procedure; - - procedure Make_Frame (Interp: in out Interpreter_Record; - Stack: in Object_Pointer; -- current stack pointer - Opcode: in Object_Pointer; - Operand: in Object_Pointer; - Result: out Object_Pointer) is - begin - Allocate_Pointer_Object (Interp, Frame_Object_Size, Nil_Pointer, Result); - Result.Tag := Frame_Object; - Result.Pointer_Slot(Frame_Stack_Index) := Stack; - Result.Pointer_Slot(Frame_Opcode_Index) := Opcode; - Result.Pointer_Slot(Frame_Operand_Index) := Operand; ---Print_Object_Pointer ("Make_Frame Result - ", Result); - end Make_Frame; - - function Make_Cons (Interp: access Interpreter_Record; - Car: in Object_Pointer; - Cdr: in Object_Pointer) return Object_Pointer is - Result: Object_Pointer; - begin - Make_Cons (Interp.all, Car, Cdr, Result); - return Result; - end Make_Cons; - function Make_Symbol (Interp: access Interpreter_Record; Source: in Object_String) return Object_Pointer is Result: Object_Pointer; @@ -862,16 +895,229 @@ Put_String (To_Thin_String_Pointer (Result)); return Result; end Make_Symbol; + ---------------------------------------------------------------------------------- + + -- TODO: change environment implementation to a table from a list + procedure Add_To_Environment (Interp: in out Interpreter_Record; + Envir: in out Object_Pointer; + Key: in Object_Pointer; + Value: in Object_Pointer) is + -- This performs no duplicate key check. + -- TODO: make environemnt a table instead of a list. + Pair: Object_Pointer; + begin + pragma Assert (Is_Symbol(Key)); + + -- TODO: make temporaries GC-aware + Pair := Make_Cons (Interp.Self, Key, Value); + Envir := Make_Cons (Interp.Self, Pair, Envir); + end Add_To_Environment; + + function Get_Environment_Cons (Interp: access Interpreter_Record; + Envir: in Object_Pointer; + Key: in Object_Pointer) return Object_Pointer is + Ptr: Object_Pointer := Envir; + Cons: Object_Pointer; + begin +Print_Object_Pointer ("Get_Environment Key => ", Key); + while Ptr /= Nil_Pointer loop + pragma Assert (Is_Cons(Ptr)); + + Cons := Get_Car(Ptr); + pragma Assert (Is_Cons(Cons)); + if Get_Car(Cons) = Key then + return Cons; + end if; + + Ptr := Get_Cdr(Ptr); + end loop; + + return null; -- not found. note that it's not Nil_Pointer. + end Get_Environment_Cons; + + function Get_Environment (Interp: access Interpreter_Record; + Envir: in Object_Pointer; + Key: in Object_Pointer) return Object_Pointer is + Cons: Object_Pointer; + begin + Cons := Get_Environment_Cons(Interp, Envir, Key); + if Cons = null then + return null; + end if; + return Get_Cdr(Cons); + end Get_Environment; + + procedure Set_Environment (Interp: in out Interpreter_Record; + Envir: in out Object_Pointer; + Key: in Object_Pointer; + Value: in Object_Pointer) is + Cons: Object_Pointer; + begin + Cons := Get_Environment_Cons (Interp.Self, Envir, Key); + if Cons = null then + -- add a new pair + Add_To_Environment (Interp, Envir, Key, Value); + else + -- overwrite an existing pair + Set_Cdr (Cons, Value); + end if; + end Set_Environment; + + ---------------------------------------------------------------------------------- + + function Is_Syntax (Source: in Object_Pointer) return Standard.Boolean is + begin + return Is_Symbol(Source) and then (Source.Flags and Syntax_Object) /= 0; + end Is_Syntax; + + procedure Make_Syntax (Interp: in out Interpreter_Record; + Opcode: in Syntax_Code; + Name: in Object_String; + Result: out Object_Pointer) is + begin + Make_Symbol (Interp, Name, Result); + Result.Flags := Result.Flags or Syntax_Object; + Result.Scode := Opcode; +Text_IO.Put ("Creating Syntax Symbol "); +Put_String (To_Thin_String_Pointer (Result)); + end Make_Syntax; + + procedure Make_Procedure (Interp: in out Interpreter_Record; + Opcode: in Procedure_Code; + Name: in Object_String; + Result: out Object_Pointer) is + -- this procedure is for internal use only + Symbol: Object_Pointer; + Proc: Object_Pointer; + begin +-- TODO: make temporaries GC-aware + -- Make a symbol for the procedure + Make_Symbol (Interp, Name, Symbol); + + -- Make the actual procedure object + Allocate_Pointer_Object (Interp, Procedure_Object_Size, Nil_Pointer, Proc); + Proc.Tag := Procedure_Object; + Proc.Pointer_Slot(Procedure_Opcode_Index) := Integer_To_Pointer(Opcode); + + -- Link it to the top environement + pragma Assert (Get_Environment (Interp.Self, Interp.Root_Environment, Symbol) = null); + Set_Environment (Interp, Interp.Root_Environment, Symbol, Proc); + + -- Set the procudure to the result. + Result := Proc; + end Make_Procedure; + + + ---------------------------------------------------------------------------------- + + function Is_Frame (Source: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_Frame); + begin + return Is_Normal_Pointer (Source) and then + Source.Tag = Frame_Object; + end Is_Frame; + + procedure Make_Frame (Interp: in out Interpreter_Record; + Stack: in Object_Pointer; -- current stack pointer + Opcode: in Object_Pointer; + Operand: in Object_Pointer; + Envir: in Object_Pointer; + Result: out Object_Pointer) is + begin + Allocate_Pointer_Object (Interp, Frame_Object_Size, Nil_Pointer, Result); + Result.Tag := Frame_Object; + Result.Pointer_Slot(Frame_Stack_Index) := Stack; + Result.Pointer_Slot(Frame_Opcode_Index) := Opcode; + Result.Pointer_Slot(Frame_Operand_Index) := Operand; + Result.Pointer_Slot(Frame_Environment_Index) := Envir; +--Print_Object_Pointer ("Make_Frame Result - ", Result); + end Make_Frame; + function Make_Frame (Interp: access Interpreter_Record; Stack: in Object_Pointer; Opcode: in Object_Pointer; - Operand: in Object_Pointer) return Object_Pointer is - Result: Object_Pointer; + Operand: in Object_Pointer; + Envir: in Object_Pointer) return Object_Pointer is + Frame: Object_Pointer; begin - Make_Frame (Interp.all, Stack, Opcode, Operand, Result); - return Result; + Make_Frame (Interp.all, Stack, Opcode, Operand, Envir, Frame); + return Frame; end Make_Frame; + function Get_Frame_Return (Frame: in Object_Pointer) return Object_Pointer is + pragma Inline (Get_Frame_Return); + begin + pragma Assert (Is_Frame(Frame)); + return Frame.Pointer_Slot(Frame_Return_Index); + end Get_Frame_Return; + + procedure Set_Frame_Return (Frame: in out Object_Pointer; + Value: in Object_Pointer) is + pragma Inline (Set_Frame_Return); + begin + pragma Assert (Is_Frame(Frame)); + Frame.Pointer_Slot(Frame_Return_Index) := Value; + end Set_Frame_Return; + + function Get_Frame_Environment (Frame: in Object_Pointer) return Object_Pointer is + pragma Inline (Get_Frame_Environment); + begin + pragma Assert (Is_Frame(Frame)); + return Frame.Pointer_Slot(Frame_Environment_Index); + end Get_Frame_Environment; + + function Get_Frame_Opcode (Frame: in Object_Pointer) return Opcode_Type is + pragma Inline (Get_Frame_Opcode); + begin + pragma Assert (Is_Frame(Frame)); + return Pointer_To_Integer(Frame.Pointer_Slot(Frame_Opcode_Index)); + end Get_Frame_Opcode; + + procedure Set_Frame_Opcode (Frame: in Object_Pointer; + OpcodE: in Opcode_Type) is + pragma Inline (Set_Frame_Opcode); + begin + pragma Assert (Is_Frame(Frame)); + Frame.Pointer_Slot(Frame_Opcode_Index) := Integer_To_Pointer(Opcode); + end Set_Frame_Opcode; + + function Get_Frame_Operand (Frame: in Object_Pointer) return Object_Pointer is + pragma Inline (Get_Frame_Operand); + begin + pragma Assert (Is_Frame(Frame)); + return Frame.Pointer_Slot(Frame_Operand_Index); + end Get_Frame_Operand; + + procedure Set_Frame_Operand (Frame: in out Object_Pointer; + Value: in Object_Pointer) is + pragma Inline (Set_Frame_Operand); + begin + pragma Assert (Is_Frame(Frame)); + Frame.Pointer_Slot(Frame_Operand_Index) := Value; + end Set_Frame_Operand; + + ---------------------------------------------------------------------------------- + + procedure Make_Closure (Interp: in out Interpreter_Record; + Code: in Object_Pointer; + Envir: in Object_Pointer; + Result: out Object_Pointer) is + begin + Allocate_Pointer_Object (Interp, Closure_Object_Size, Nil_Pointer, Result); + Result.Tag := Closure_Object; + Result.Pointer_Slot(Closure_Code_Index) := Code; + Result.Pointer_Slot(Closure_Environment_Index) := Envir; + end Make_Closure; + + function Make_Closure (Interp: access Interpreter_Record; + Code: in Object_Pointer; + Envir: in Object_Pointer) return Object_Pointer is + Closure: Object_Pointer; + begin + Make_Closure (Interp.all, Code, Envir, Closure); + return Closure; + end Make_Closure; + ---------------------------------------------------------------------------------- procedure Deinitialize_Heap (Interp: in out Interpreter_Record) is begin @@ -923,20 +1169,33 @@ Put_String (To_Thin_String_Pointer (Result)); procedure Make_Syntax_Objects is Dummy: Object_Pointer; begin - Make_Syntax (Interp, AND_SYNTAX, "and", Dummy); - Make_Syntax (Interp, BEGIN_SYNTAX, "begin", Dummy); - Make_Syntax (Interp, CASE_SYNTAX, "case", Dummy); - Make_Syntax (Interp, COND_SYNTAX, "cond", Dummy); - Make_Syntax (Interp, DEFINE_SYNTAX, "define", Dummy); - Make_Syntax (Interp, IF_SYNTAX, "if", Dummy); - Make_Syntax (Interp, LAMBDA_SYNTAX, "lambda", Dummy); - Make_Syntax (Interp, LET_SYNTAX, "let", Dummy); - Make_Syntax (Interp, LETAST_SYNTAX, "let*", Dummy); - Make_Syntax (Interp, LETREC_SYNTAX, "letrec", Dummy); - Make_Syntax (Interp, OR_SYNTAX, "or", Dummy); - Make_Syntax (Interp, QUOTE_SYNTAX, "quote", Dummy); - Make_Syntax (Interp, SET_SYNTAX, "set!", Dummy); + Make_Syntax (Interp, And_Syntax, "and", Dummy); + Make_Syntax (Interp, Begin_Syntax, "begin", Dummy); + Make_Syntax (Interp, Case_Syntax, "case", Dummy); + Make_Syntax (Interp, Cond_Syntax, "cond", Dummy); + Make_Syntax (Interp, Define_Syntax, "define", Dummy); + Make_Syntax (Interp, If_Syntax, "if", Dummy); + Make_Syntax (Interp, Lambda_Syntax, "lambda", Dummy); + Make_Syntax (Interp, Let_Syntax, "let", Dummy); + Make_Syntax (Interp, Letast_Syntax, "let*", Dummy); + Make_Syntax (Interp, Letrec_Syntax, "letrec", Dummy); + Make_Syntax (Interp, Or_Syntax, "or", Dummy); + Make_Syntax (Interp, Quote_Syntax, "quote", Dummy); + Make_Syntax (Interp, Set_Syntax, "set!", Dummy); end Make_Syntax_Objects; + + procedure Make_Procedure_Objects is + Dummy: Object_Pointer; + begin + Make_Procedure (Interp, Car_Procedure, "car", Dummy); + Make_Procedure (Interp, Cdr_Procedure, "cdr", Dummy); + Make_Procedure (Interp, Setcar_Procedure, "setcar", Dummy); + Make_Procedure (Interp, Setcdr_Procedure, "setcdr", Dummy); + Make_Procedure (Interp, Add_Procedure, "+", Dummy); + Make_Procedure (Interp, Subtract_Procedure, "-", Dummy); + Make_Procedure (Interp, Multiply_Procedure, "*", Dummy); + Make_Procedure (Interp, Divide_Procedure, "/", Dummy); + end Make_Procedure_Objects; begin declare Aliased_Interp: aliased Interpreter_Record; @@ -963,12 +1222,16 @@ Put_String (To_Thin_String_Pointer (Result)); Interp.Storage_Pool := Storage_Pool; Interp.Root_Table := Nil_Pointer; Interp.Symbol_Table := Nil_Pointer; - Interp.Environment := Nil_Pointer; + Interp.Root_Environment := Nil_Pointer; + Interp.Environment := Interp.Root_Environment; + + Interp.Line_Pos := Interp.Line'First - 1; + Interp.Line_Last := Interp.Line'First - 1; -- TODO: disallow garbage collecion during initialization. Initialize_Heap (Initial_Heap_Size); Make_Syntax_Objects; - + Make_Procedure_Objects; exception when others => Deinitialize_Heap (Interp); @@ -983,7 +1246,7 @@ Put_String (To_Thin_String_Pointer (Result)); Option: in Option_Record) is begin case Option.Kind is - when Trait_Option => + when Trait_Option => Interp.Trait := Option; end case; end Set_Option; @@ -992,11 +1255,57 @@ Put_String (To_Thin_String_Pointer (Result)); Option: in out Option_Record) is begin case Option.Kind is - when Trait_Option => + when Trait_Option => Option := Interp.Trait; end case; end Get_Option; + procedure Read (Interp: in out Interpreter_Record; + Result: out Object_Pointer) is + + EOF_Error: exception; + + function Get_Character return Object_Character is + begin + if Interp.Line_Pos >= Interp.Line_Last then + if Text_IO.End_Of_File then + raise EOF_Error; + end if; + Text_IO.Get_Line (Interp.Line, Interp.Line_Last); + Interp.Line_Pos := Interp.Line'First - 1; + end if; + + Interp.Line_Pos := Interp.Line_Pos + 1; + return Interp.Line(Interp.Line_Pos); + end Get_Character; + + procedure Skip_Space is + begin + null; + end Skip_Space; + + --function Get_Token is + --begin + -- null; + --end Get_Token; + + procedure Read_Atom (Atom: out Object_Pointer) is + begin + null; + end Read_Atom; + + Stack: Object_Pointer; + Opcode: Object_Integer; + Operand: Object_Pointer; + begin + --Opcode := 1; + --loop + -- case Opcode is + -- when 1 => + --end loop; + null; + end Read; + procedure Print (Interp: in out Interpreter_Record; Source: in Object_Pointer) is @@ -1008,39 +1317,42 @@ Put_String (To_Thin_String_Pointer (Result)); for W'Address use Atom'Address; begin case W is - when Nil_Word => - Text_IO.Put ("()"); + when Nil_Word => + Text_IO.Put ("()"); - when True_Word => - Text_IO.Put ("#t"); + when True_Word => + Text_IO.Put ("#t"); - when False_Word => - Text_IO.Put ("#f"); + when False_Word => + Text_IO.Put ("#f"); - when others => - case Atom.Tag is - when Cons_Object => - -- Cons_Object must not reach here. - raise Internal_Error; + when others => + case Atom.Tag is + when Cons_Object => + -- Cons_Object must not reach here. + raise Internal_Error; - when Symbol_Object => - Text_IO.Put (To_String (Atom.Character_Slot)); + when Symbol_Object => + Text_IO.Put (To_String (Atom.Character_Slot)); - when String_Object => - Text_IO.Put (""""); - Text_IO.Put (To_String (Atom.Character_Slot)); - Text_IO.Put (""""); + when String_Object => + Text_IO.Put (""""); + Text_IO.Put (To_String (Atom.Character_Slot)); + Text_IO.Put (""""); - when Continuation_Object => - Text_IO.Put ("#Continuation"); - - when Others => - if Atom.Kind = Character_Object then - Text_IO.Put (To_String (Atom.Character_Slot)); - else - Text_IO.Put ("#NOIMPL#"); - end if; - end case; + when Continuation_Object => + Text_IO.Put ("#Continuation"); + + when Procedure_Object => + Text_IO.Put ("#Procedure"); + + when Others => + if Atom.Kind = Character_Object then + Text_IO.Put (To_String (Atom.Character_Slot)); + else + Text_IO.Put ("#NOIMPL#"); + end if; + end case; end case; end Print_Pointee; @@ -1063,19 +1375,19 @@ Put_String (To_Thin_String_Pointer (Result)); end Print_Byte; begin - Ptr_Type := Get_Pointer_Type (Atom); + Ptr_Type := Get_Pointer_Type(Atom); case Ptr_Type is - when Object_Pointer_Type_Pointer => - Print_Pointee; + when Object_Pointer_Type_Pointer => + Print_Pointee; - when Object_Pointer_Type_Integer => - Print_Integer; + when Object_Pointer_Type_Integer => + Print_Integer; - when Object_Pointer_Type_Character => - Print_Character; + when Object_Pointer_Type_Character => + Print_Character; - when Object_Pointer_Type_Byte => - Print_Byte; + when Object_Pointer_Type_Byte => + Print_Byte; end case; end Print_Atom; @@ -1090,7 +1402,7 @@ Put_String (To_Thin_String_Pointer (Result)); Text_IO.Put ("("); loop - Car := Cons.Pointer_Slot (Cons_Car_Index); + Car := Get_Car(Cons); if Is_Cons (Car) then Print_Object (Car); @@ -1098,7 +1410,7 @@ Put_String (To_Thin_String_Pointer (Result)); Print_Atom (Car); end if; - Cdr := Cons.Pointer_Slot (Cons_Cdr_Index); + Cdr := Get_Cdr(Cons); if Is_Cons (Cdr) then Text_IO.Put (" "); Cons := Cdr; @@ -1119,7 +1431,7 @@ Put_String (To_Thin_String_Pointer (Result)); end Print_Object; - Stack: Object_Pointer; + Stack: Object_Pointer; -- TODO: make it into the interpreter_Record so that GC can workd Opcode: Object_Integer; Operand: Object_Pointer; @@ -1127,57 +1439,59 @@ Put_String (To_Thin_String_Pointer (Result)); -- TODO: Let Make_Frame use a dedicated stack space that's apart from the heap. -- This way, the stack frame doesn't have to be managed by GC. + Stack := Make_Frame (Interp.Self, Nil_Pointer, Integer_To_Pointer(0), Nil_Pointer, Interp.Root_Environment); -- just for get_frame_environment... + Opcode := 1; Operand := Source; - Stack := Nil_Pointer; -- make it to the interpreter so that GC can work loop case Opcode is - when 1 => - if Is_Cons(Operand) then - -- push cdr - Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Operand.Pointer_Slot(Cons_Cdr_Index)); -- push cdr - Text_IO.Put ("("); - Operand := Operand.Pointer_Slot(Cons_Car_Index); -- car - Opcode := 1; + when 1 => + if Is_Cons(Operand) then + -- push cdr + Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Get_Frame_Environment(Stack)); -- push cdr + Text_IO.Put ("("); + Operand := Get_Car(Operand); + Opcode := 1; + else + Print_Atom (Operand); + if Stack = Nil_Pointer then + Opcode := 0; -- stack empty. arrange to exit + Operand := True_Pointer; -- return value else + Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index)); + Operand := Stack.Pointer_Slot(Frame_Operand_Index); + Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop + end if; + end if; + + when 2 => + + if Is_Cons(Operand) then + -- push cdr + Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Get_Frame_Environment(Stack)); -- push + Text_IO.Put (" "); + Operand := Get_Car(Operand); -- car + Opcode := 1; + else + if Operand /= Nil_Pointer then + -- cdr of the last cons cell is not null. + Text_IO.Put (" . "); Print_Atom (Operand); - if Stack = Nil_Pointer then - Opcode := 0; - else - Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index)); - Operand := Stack.Pointer_Slot(Frame_Operand_Index); - Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop - end if; end if; + Text_IO.Put (")"); - when 2 => - - if Is_Cons(Operand) then - -- push cdr - Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Operand.Pointer_Slot(Cons_Cdr_Index)); -- push - Text_IO.Put (" "); - Operand := Operand.Pointer_Slot(Cons_Car_Index); -- car - Opcode := 1; + if Stack = Nil_Pointer then + Opcode := 0; -- stack empty. arrange to exit else - if Operand /= Nil_Pointer then - -- cdr of the last cons cell is not null. - Text_IO.Put (" . "); - Print_Atom (Operand); - end if; - Text_IO.Put (")"); - - if Stack = Nil_Pointer then - Opcode := 0; - else - Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index)); - Operand := Stack.Pointer_Slot(Frame_Operand_Index); - Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop - end if; + Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index)); + Operand := Stack.Pointer_Slot(Frame_Operand_Index); + Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop end if; + end if; - when others => - exit; + when others => + exit; end case; end loop; @@ -1185,7 +1499,7 @@ Put_String (To_Thin_String_Pointer (Result)); Text_IO.New_Line; end Print; - procedure Evaluate (Interp: in out Interpreter_Record) is + procedure Evaluatex (Interp: in out Interpreter_Record) is X: Object_Pointer; begin --Make_Cons (Interpreter, Nil_Pointer, Nil_Pointer, X); @@ -1217,9 +1531,242 @@ Make_Symbol (Interp, "lambda", Interp.Root_Table); --X := Make_Cons (Interp.Self, Nil_Pointer, Make_Cons (Interp.Self, Nil_Pointer, Integer_To_Pointer(TEN))); --X := Make_Cons (Interp.Self, Nil_Pointer, Nil_Pointer); + Read (Interp, X); Print (Interp, X); + end Evaluatex; + +procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Object_Pointer) is +begin + --(define x 10) + --Result := Make_Cons ( + -- Interp.Self, + -- Make_Symbol (Interp.Self, "define"), + -- Make_Cons ( + -- Interp.Self, + -- Make_Symbol (Interp.Self, "x"), + -- Make_Cons ( + -- Interp.Self, + -- Integer_To_Pointer (10), + -- --Nil_Pointer + -- Integer_To_Pointer (10) + -- ) + -- ) + --); + + -- (+ 1 2 . 2) + Result := Make_Cons ( + Interp.Self, + Make_Symbol (Interp.Self, "+"), + Make_Cons ( + Interp.Self, + Integer_To_Pointer (10), + Make_Cons ( + Interp.Self, + Integer_To_Pointer (20), + Integer_To_Pointer (2) + ) + ) + ); +end Make_Test_Object; + + + function Pointer_To_Opcode (Pointer: in Object_Pointer) return Opcode_Type is + pragma Inline (Pointer_To_Opcode); + begin + return 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); + end Opcode_To_Pointer; + + procedure Evaluate (Interp: in out Interpreter_Record; + Source: in Object_Pointer; + Result: out Object_Pointer) is + + procedure Push_Frame (Stack: in out Object_Pointer; + Opcode: in Opcode_Type; + Operand: in Object_Pointer; + Envir: in Object_Pointer) is + pragma Inline (Push_Frame); + begin + Stack := Make_Frame (Interp.Self, Stack, Opcode_To_Pointer(Opcode), Operand, Envir); + end Push_Frame; + + --procedure Pop_Frame (Stack: out Object_Pointer; + -- Opcode: out Opcode_Type; + -- Operand: out Object_Pointer) is + -- pragma Inline (Pop_Frame); + --begin + -- pragma Assert (Stack /= Nil_Pointer); + -- Opcode := Pointer_To_Opcode(Stack.Pointer_Slot(Frame_Opcode_Index)); + -- Operand := Stack.Pointer_Slot(Frame_Operand_Index); + -- Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop + --end Pop_Frame; + + procedure Pop_Frame (Stack: out Object_Pointer) is + pragma Inline (Pop_Frame); + begin + pragma Assert (Stack /= Nil_Pointer); + Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop + end Pop_Frame; + + procedure Evaluate_Object (Stack: in out Object_Pointer) is + pragma Inline (Evaluate_Object); + + Operand: Object_Pointer; + Operand_Word: Object_Word; + for Operand_Word'Address use Operand'Address; + + Tmp: Object_Pointer; + begin +Text_IO.Put_Line ("Evaluate_Object..."); + Operand := Get_Frame_Operand (Stack); + + if Get_Pointer_Type(Operand) /= Object_Pointer_Type_Pointer then +Text_IO.Put_Line ("NON_POINTER..."); + goto Literal; + end if; + +Print_Object_Pointer ("Operand => ", Operand); + case Operand_Word is + when Nil_Word | True_Word | False_Word => + -- special literal object +Text_IO.Put_Line ("SPECIAL POINTER..."); + goto Literal; + + when others => +Text_IO.Put_Line ("OTHER BDONE.." & Object_Tag'Image(Operand.Tag)); + + case Operand.Tag is + when Symbol_Object => -- Is_Symbol(Operand) + Tmp := Get_Environment (Interp.Self, Get_Frame_Environment(Stack), Operand); -- TODO: use current environent + if Tmp = null then + -- unbound + Text_IO.Put_Line ("Unbound symbol...."); + else + -- symbol found in the environment +Text_IO.Put_Line ("SUMBOL BDONE.."); + Operand := Tmp; + goto Literal; -- In fact, this is not a literal, but can be handled in the same way + end if; + + when Cons_Object => -- Is_Cons(Operand) + Tmp := Get_Car(Operand); + if Is_Syntax(Tmp) then +Text_IO.Put_Line ("SYNTAX .."); + -- special syntax symbol. normal evaluate rule doesn't + -- apply for special syntax objects. + --Opcode := Syntax_To_Opcode(Operand); + Set_Frame_Opcode (Stack, Opcode_Evaluate_Syntax); -- switch to syntax evaluation + else +Text_IO.Put_Line ("NON_SYNTAX .."); + declare + Cdr: Object_Pointer := Get_Cdr(Operand); + begin + if Is_Cons(Cdr) then + Set_Frame_Operand (Stack, Cdr); -- change the operand for the next call + Push_Frame (Stack, Opcode_Evaluate_Object, Tmp, Get_Frame_Environment(Stack)); + else + if Cdr /= Nil_Pointer then + Text_IO.Put_Line ("..................FUCKING CDR....................."); + end if; + Operand := Get_Frame_Return(Stack); + Set_Frame_Opcode (Stack, Opcode_Apply); + end if; + end; + end if; + + when others => + -- normal literal object +Text_IO.Put_Line ("nORMAL LITERAL POINTER..."); + goto Literal; + end case; + end case; + + return; + + <> + Pop_Frame (Stack); -- done +Print_Object_Pointer ("Return => ", Operand); + Set_Frame_Return (Stack, Operand); + end Evaluate_Object; + + procedure Evaluate_Argument (Stack: in out Object_Pointer) is + begin + null; + end Evaluate_Argument; + + procedure Evaluate_Syntax (Stack: in out Object_Pointer) is + Scode: Syntax_Code; + begin + Scode := Get_Car(Get_Frame_Operand(Stack)).Scode; + case Scode is + when Define_Syntax => + Text_IO.Put_Line ("define syntax"); + when others => + Text_IO.Put_Line ("Unknown syntax"); + end case; + end Evaluate_Syntax; + + procedure Evaluate_Procedure (Stack: in out Object_Pointer) is + begin + null; + end Evaluate_Procedure; + + procedure Apply (Stack: in out Object_Pointer) is + begin + null; + end Apply; + + Stack: Object_Pointer; -- TODO: make it into the interpreter_Record so that GC can workd + + begin + Stack := Nil_Pointer; + + -- Push a pseudo-frame to terminate the evaluation loop + Push_Frame (Stack, Opcode_Exit, Nil_Pointer, Interp.Root_Environment); + + -- Push the actual frame for evaluation + Push_Frame (Stack, Opcode_Evaluate_Object, Source, Interp.Root_Environment); + + loop + case Get_Frame_Opcode(Stack) is + when Opcode_Evaluate_Object => + Evaluate_Object (Stack); + + when Opcode_Evaluate_Argument => + Evaluate_Argument (Stack); + + when Opcode_Evaluate_Syntax => + Evaluate_Syntax (Stack); + + when Opcode_Evaluate_Procedure => + Evaluate_Procedure (Stack); + + when Opcode_Apply => + Apply (Stack); + + when Opcode_Exit => + Result := Get_Frame_Return (Stack); + Pop_Frame (Stack); + exit; + end case; + end loop; + + -- the stack must be empty when the loop is terminated + pragma Assert (Stack = Nil_Pointer); + end Evaluate; - end H2.Scheme; + + + +--(+ (+ 1 2) (+ 1 2)) +--push | eval | expr | result | + + diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 0365a04..678e956 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -123,23 +123,32 @@ package H2.Scheme is -- freely for management purpose. The Object_Flags type -- represents the value that can be stored in this field. type Object_Flags is mod 2 ** 4; - Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#); + Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#); type Syntax_Code is mod 2 ** 4; - AND_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - BEGIN_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - CASE_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - COND_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - DEFINE_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - IF_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - LAMBDA_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - LET_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - LETAST_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - LETREC_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - OR_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - QUOTE_SYNTAX: constant Syntax_Code := Syntax_Code'(0); - SET_SYNTAX: constant Syntax_Code := Syntax_Code'(0); + And_Syntax: constant Syntax_Code := Syntax_Code'(0); + Begin_Syntax: constant Syntax_Code := Syntax_Code'(1); + Case_Syntax: constant Syntax_Code := Syntax_Code'(2); + Cond_Syntax: constant Syntax_Code := Syntax_Code'(3); + Define_Syntax: constant Syntax_Code := Syntax_Code'(4); + If_Syntax: constant Syntax_Code := Syntax_Code'(5); + Lambda_Syntax: constant Syntax_Code := Syntax_Code'(6); + Let_Syntax: constant Syntax_Code := Syntax_Code'(7); + Letast_Syntax: constant Syntax_Code := Syntax_Code'(8); + Letrec_Syntax: constant Syntax_Code := Syntax_Code'(9); + Or_Syntax: constant Syntax_Code := Syntax_Code'(10); + Quote_Syntax: constant Syntax_Code := Syntax_Code'(11); + Set_Syntax: constant Syntax_Code := Syntax_Code'(12); + subtype Procedure_Code is Object_Integer; + Car_Procedure: constant Procedure_Code := Procedure_Code'(0); + Cdr_Procedure: constant Procedure_Code := Procedure_Code'(1); + Setcar_Procedure: constant Procedure_Code := Procedure_Code'(2); + Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(3); + Add_Procedure: constant Procedure_Code := Procedure_Code'(4); + Subtract_Procedure: constant Procedure_Code := Procedure_Code'(5); + Multiply_Procedure: constant Procedure_Code := Procedure_Code'(6); + Divide_Procedure: constant Procedure_Code := Procedure_Code'(7); type Object_Tag is ( Unknown_Object, @@ -149,7 +158,8 @@ package H2.Scheme is Number_Object, Array_Object, Table_Object, - Lambda_Object, + Procedure_Object, + Closure_Object, Continuation_Object, Frame_Object ); @@ -287,15 +297,38 @@ package H2.Scheme is type Interpreter_Record is limited private; + type Interpreter_Text_IO_Record is abstract tagged null record; + + procedure Open (IO: in out Interpreter_Text_IO_Record; + Name: in Object_String) is abstract; + + procedure Close (IO: in out Interpreter_Text_IO_Record) is abstract; + + procedure Read (IO: in out Interpreter_Text_IO_Record; + Data: in Object_String; + Last: in Standard.Natural) is abstract; + + procedure Write (IO: in out Interpreter_Text_IO_Record; + Data: out Object_String; + Last: out Standard.Natural) is abstract; + + -- ----------------------------------------------------------------------------- +procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Object_Pointer); + procedure Open (Interp: in out Interpreter_Record; Initial_Heap_Size:in Memory_Size; Storage_Pool: in Storage_Pool_Pointer := null); procedure Close (Interp: in out Interpreter_Record); - procedure Evaluate (Interp: in out Interpreter_Record); + procedure Evaluate (Interp: in out Interpreter_Record; + Source: in Object_Pointer; + Result: out Object_Pointer); + + procedure Print (Interp: in out Interpreter_Record; + Source: in Object_Pointer); procedure Set_Option (Interp: in out Interpreter_Record; Option: in Option_Record); @@ -310,7 +343,7 @@ private type Heap_Array is array (Memory_Size range <>) of aliased Memory_Element; type Heap_Record (Size: Memory_Size) is record - Space: Heap_Array (1 .. Size) := (others => 0); + Space: Heap_Array(1..Size) := (others => 0); Bound: Memory_Size := 0; end record; for Heap_Record'Alignment use Object_Pointer_Bytes; @@ -327,20 +360,26 @@ private end record; type Interpreter_Pointer is access all Interpreter_Record; + --type Interpreter_Record is tagged limited record type Interpreter_Record is limited record Self: Interpreter_Pointer := null; Storage_Pool: Storage_Pool_Pointer := null; - Trait: Option_Record (Trait_Option); + Trait: Option_Record(Trait_Option); Heap: Heap_Pointer_Array := (others => null); Current_Heap: Heap_Number := Heap_Number'First; Root_Table: Object_Pointer := Nil_Pointer; Symbol_Table: Object_Pointer := Nil_Pointer; + Root_Environment: Object_Pointer := Nil_Pointer; Environment: Object_Pointer := Nil_Pointer; Stack: Object_Pointer := Nil_Pointer; R: Register_Record; + + Line: Object_String(1..1024); + Line_Last: Standard.Natural; + Line_Pos: Standard.Natural; end record; end H2.Scheme;