diff --git a/cmd/scheme.adb b/cmd/scheme.adb index aab0250..3b42aed 100644 --- a/cmd/scheme.adb +++ b/cmd/scheme.adb @@ -15,57 +15,34 @@ procedure scheme is O: S.Object_Pointer; --String: aliased S.Object_String := "(car '(1 2 3))"; - String: aliased S.Object_String := "((lambda (x y) (+ x y)) 9 7)"; + String: aliased constant S.Object_String := "((lambda (x y) (+ x y)) 9 7)"; String_Stream: Stream.String_Input_Stream_Record (String'Unchecked_Access); --String_Stream: Stream.String_Input_Stream_Record := (Len => String'Length, Str => String, Pos => 0); - File_Name: aliased S.Object_String := "test.adb"; + --File_Name: aliased S.Object_String := "test.adb"; + File_Name: aliased constant S.Object_String := "test.adb"; --File_Stream: Stream.File_Stream_Record (File_Name'Unchecked_Access); --File_Stream: Stream.File_Stream_Record := (Name => File_Name'Unchecked_Access); File_Stream: Stream.File_Stream_Record; - procedure Allocate_Stream (Interp: in out S.Interpreter_Record; - Name: access S.Object_String; - Result: in out S.Stream_Pointer) is - subtype FSR is Stream.File_Stream_Record; - type FSP is access all FSR; - package P is new H2.Pool (FSR, FSP); - - X: FSP; - for X'Address use Result'Address; - pragma Import (Ada, X); - begin - X := P.Allocate (S.Get_Storage_Pool(Interp)); - X.Name := Stream.Object_String_Pointer(Name); - end Allocate_Stream; - - procedure Deallocate_Stream (Interp: in out S.Interpreter_Record; - Source: in out S.Stream_Pointer) is - subtype FSR is Stream.File_Stream_Record; - type FSP is access all FSR; - package P is new H2.Pool (FSR, FSP); - - X: FSP; - for X'Address use Source'Address; - pragma Import (Ada, X); - begin - P.Deallocate (X, S.Get_Storage_Pool(Interp)); - end Deallocate_Stream; - --- --procedure Dealloc_Stream is new Ada.Unchecked_Deallocation (Stream_Record'Class, Stream_Pointer); --- --procedure Destroy_Stream (Stream: in out Stream_Pointer) renames Dealloc_Stream; - - 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); -File_Stream.Name := File_Name'Unchecked_Access; -S.Set_Input_Stream (SI, File_Stream); -- specify main input stream ---S.Set_Output_Stream (SI, Stream); -- specify main output stream. + -- Specify the named stream handler + S.Set_Option (SI, (S.Stream_Option, + Stream.Allocate_Stream'Access, + Stream.Deallocate_Stream'Access) + ); + + File_Stream.Name := File_Name'Unchecked_Access; + S.Set_Input_Stream (SI, File_Stream); -- specify main input stream + --S.Set_Input_Stream (SI, String_Stream); + --S.Set_Output_Stream (SI, Stream); -- specify main output stream. + S.Read (SI, I); S.Make_Test_Object (SI, I); @@ -107,5 +84,4 @@ S.Print (SI, O); Ada.Text_IO.Put_Line ("BYE..."); - end scheme; diff --git a/cmd/stream.adb b/cmd/stream.adb index 2784345..84505dc 100644 --- a/cmd/stream.adb +++ b/cmd/stream.adb @@ -1,3 +1,5 @@ +with H2.Pool; +with Ada.Characters.Conversions; package body Stream is @@ -5,13 +7,13 @@ package body Stream is procedure Open (Stream: in out String_Input_Stream_Record) is begin -Ada.Text_IO.Put_Line ("OPEN STRING STREAM"); +Ada.Wide_Text_IO.Put_Line ("****** OPEN STRING STREAM ******"); Stream.Pos := 0; end Open; procedure Close (Stream: in out String_Input_Stream_Record) is begin -Ada.Text_IO.Put_Line ("CLOSE STRING STREAM"); +Ada.Wide_Text_IO.Put_Line ("****** CLOSE STRING STREAM ******"); Stream.Pos := Stream.Str'Last; end Close; @@ -47,14 +49,14 @@ Ada.Text_IO.Put_Line ("CLOSE STRING STREAM"); procedure Open (Stream: in out File_Stream_Record) is begin -Ada.Text_IO.Put_Line ("OPEN File STREAM"); - Ada.Text_IO.Open (Stream.Handle, Ada.Text_IO.In_File, Stream.Name.all); +Ada.Wide_Text_IO.Put_Line (">>>>> OPEN File STREAM <<<<<"); + Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Ada.Characters.Conversions.To_String(Stream.Name.all)); end Open; procedure Close (Stream: in out File_Stream_Record) is begin -Ada.Text_IO.Put_Line ("CLOSE File STREAM"); - Ada.Text_IO.Close (Stream.Handle); +Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<<"); + Ada.Wide_Text_IO.Close (Stream.Handle); end Close; procedure Read (Stream: in out File_Stream_Record; @@ -63,9 +65,9 @@ Ada.Text_IO.Put_Line ("CLOSE File STREAM"); begin for I in Data'First .. Data'Last loop begin - Ada.Text_IO.Get_Immediate (Stream.Handle, Data(I)); + Ada.Wide_Text_IO.Get_Immediate (Stream.Handle, Data(I)); exception - when Ada.Text_IO.End_Error => + when Ada.Wide_Text_IO.End_Error => Last := I - 1; return; -- other exceptions must be just raised to indicate errors @@ -84,4 +86,31 @@ Ada.Text_IO.Put_Line ("CLOSE File STREAM"); ------------------------------------------------------------------ + procedure Allocate_Stream (Interp: in out S.Interpreter_Record; + Name: in S.Constant_Object_String_Pointer; + Result: out S.Stream_Pointer) is + subtype FSR is Stream.File_Stream_Record; + type FSP is access all FSR; + package P is new H2.Pool (FSR, FSP); + + X: FSP; + for X'Address use Result'Address; + pragma Import (Ada, X); + begin + X := P.Allocate (S.Get_Storage_Pool(Interp)); + X.Name := Name; + end Allocate_Stream; + + procedure Deallocate_Stream (Interp: in out S.Interpreter_Record; + Source: in out S.Stream_Pointer) is + subtype FSR is Stream.File_Stream_Record; + type FSP is access all FSR; + package P is new H2.Pool (FSR, FSP); + + X: FSP; + for X'Address use Source'Address; + pragma Import (Ada, X); + begin + P.Deallocate (X, S.Get_Storage_Pool(Interp)); + end Deallocate_Stream; end Stream; diff --git a/cmd/stream.ads b/cmd/stream.ads index 7b24b02..7f4873a 100644 --- a/cmd/stream.ads +++ b/cmd/stream.ads @@ -1,12 +1,13 @@ with H2.Scheme; -with Ada.Text_IO; +with Ada.Wide_Text_IO; package Stream is package S renames H2.Scheme; ------------------------------------------------------------ - type Object_String_Pointer is access all S.Object_String; + --type Object_String_Pointer is access all S.Object_String; + type Object_String_Pointer is access constant S.Object_String; type String_Input_Stream_Record(Str: Object_String_Pointer) is new S.Stream_Record with record Pos: Standard.Natural := 0; end record; @@ -27,14 +28,15 @@ package Stream is ------------------------------------------------------------ --type File_Stream_Record(Name: Object_String_Pointer) is new S.Stream_Record with record - -- Handle: Ada.Text_IO.File_Type; + -- Handle: H2.Text_IO.File_Type; --end record; type File_Stream_Record is new S.Stream_Record with record - Name: Object_String_Pointer; - Handle: Ada.Text_IO.File_Type; + Name: S.Constant_Object_String_Pointer; + Handle: Ada.Wide_Text_IO.File_Type; end record; + procedure Open (Stream: in out File_Stream_Record); procedure Close (Stream: in out File_Stream_Record); procedure Read (Stream: in out File_Stream_Record; @@ -44,5 +46,19 @@ package Stream is Data: out S.Object_String; Last: out Standard.Natural); + ------------------------------------------------------------ + procedure Allocate_Stream (Interp: in out S.Interpreter_Record; + Name: in S.Constant_Object_String_Pointer; + Result: out S.Stream_Pointer); + + procedure Deallocate_Stream (Interp: in out S.Interpreter_Record; + Source: in out S.Stream_Pointer); + +--private +-- type File_Stream_Record is new S.Stream_Record with record +-- Name: S.Constant_Object_String_Pointer; +-- Handle: Ada.Wide_Text_IO.File_Type; +-- end record; + end Stream; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index b76ecdc..41d5b70 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -5,8 +5,24 @@ with System.Address_To_Access_Conversions; with Ada.Unchecked_Deallocation; -- for h2scm c interface. TOOD: move it to a separate file with Interfaces.C; + +-- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx +with Ada.Characters.Handling; +with Ada.Characters.Conversions; +with Ada.Wide_Characters.Handling; + +-- TODO: delete these after debugging +with ada.text_io; +with ada.wide_text_io; +-- TODO: delete above after debugging + +-- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx + package body H2.Scheme is + function To_Object_String (Item: in Standard.String) return Object_String renames Ada.Characters.Conversions.To_Wide_String; + package Text_IO renames ada.Wide_Text_IO; + ----------------------------------------------------------------------------- -- EXCEPTIONS ----------------------------------------------------------------------------- @@ -15,6 +31,7 @@ package body H2.Scheme is Syntax_Error: exception; Evaluation_Error: exception; Internal_Error: exception; + IO_Error: exception; ----------------------------------------------------------------------------- -- INTERNALLY-USED TYPES @@ -158,7 +175,7 @@ package body H2.Scheme is -- or short. In reality, the last Unicode code point assigned is far -- less than #16#7FFFFFFF# as of this writing. So I should not be -- worried about it for the time being. - Word := Object_Character'Pos (Char); + Word := Object_Character'Pos(Char); Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Character); --return Object_Word_To_Object_Pointer (Word); return Pointer; @@ -199,7 +216,7 @@ package body H2.Scheme is function Pointer_To_Character (Pointer: in Object_Pointer) return Object_Character is Word: Object_Word := Pointer_To_Word (Pointer); begin - return Object_Character'Val (Word / (2 ** Object_Pointer_Type_Bits)); + return Object_Character'Val(Word / (2 ** Object_Pointer_Type_Bits)); end Pointer_To_Character; function Pointer_To_Byte (Pointer: in Object_Pointer) return Object_Byte is @@ -269,7 +286,7 @@ package body H2.Scheme is end; end Copy_String; - function To_String (Source: in Object_Character_Array) return Object_String is + function Character_Array_To_String (Source: in Object_Character_Array) return Object_String is begin -- ObjectAda complains that the member of Object_String is not -- aliased because Object_Character_Array is an array of aliased @@ -283,7 +300,7 @@ package body H2.Scheme is return To_Character_Array (Source (Source'First .. Source'Last - 1)); --return String_Array (Source (Source'First .. Source'Last - 1)); end; - end To_String; + end Character_Array_To_String; type Thin_String is new Object_String (Standard.Positive'Range); type Thin_String_Pointer is access all Thin_String; @@ -329,20 +346,22 @@ package body H2.Scheme is begin 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))); + Text_IO.Put_Line (Msg & To_Object_String(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))); + Text_IO.Put_Line (Msg & To_Object_String(Object_Integer'Image(Pointer_To_Integer(Source)))); elsif Is_Special_Pointer (Source) then - Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W)); + Text_IO.Put_Line (Msg & " at " & To_Object_String(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) & " - "); + Text_IO.Put (Msg & " at " & To_Object_String(Object_Word'Image(W)) & + " at " & To_Object_String(Object_Kind'Image(Source.Kind)) & + " size " & To_Object_String(Object_Size'Image(Source.Size)) & " - "); if Source.Kind = Moved_Object then - Text_IO.Put_Line (To_String (Get_New_Location(Source).Character_Slot)); + Text_IO.Put_Line (Character_Array_To_String (Get_New_Location(Source).Character_Slot)); else - Text_IO.Put_Line (To_String (Source.Character_Slot)); + Text_IO.Put_Line (Character_Array_To_String (Source.Character_Slot)); end if; else - Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W) & " at " & Object_Kind'Image(Source.Kind)); + Text_IO.Put_Line (Msg & " at " & To_Object_String(Object_Word'Image(W)) & " at " & To_Object_String(Object_Kind'Image(Source.Kind))); end if; end Print_Object_Pointer; @@ -541,8 +560,8 @@ Print_Object_Pointer ("Moving REALLY ...", Object); -- if the object is marked with FLAG_MOVED; Set_New_Location (Object, Ptr); -Text_IO.Put_Line (Object_Word'Image(Pointer_To_Word(Object)) & Object_Word'Image(Pointer_To_Word(New_Object))); -Text_IO.Put_Line (" Flags....after " & Object_Kind'Image(Object.Kind) & " New Size " & Object_Size'Image(Object.Size) & " New Loc: " & Object_Word'Image(Pointer_To_Word(Object.New_Pointer))); +Ada.Text_IO.Put_Line (Object_Word'Image(Pointer_To_Word(Object)) & Object_Word'Image(Pointer_To_Word(New_Object))); +Ada.Text_IO.Put_Line (" Flags....after " & Object_Kind'Image(Object.Kind) & " New Size " & Object_Size'Image(Object.Size) & " New Loc: " & Object_Word'Image(Pointer_To_Word(Object.New_Pointer))); -- Return the new object return New_Object; end; @@ -614,7 +633,7 @@ Text_IO.Put_Line (" Flags....after " & Object_Kind'Image(Object.Kind) & " New S -- A non-syntax symbol has not been moved. -- Unlink the cons cell from the symbol table. -Text_IO.Put_Line ("COMPACT_SYMBOL_TABLE Unlinking " & To_String (Car.Character_Slot)); +Text_IO.Put_Line ("COMPACT_SYMBOL_TABLE Unlinking " & Character_Array_To_String (Car.Character_Slot)); if Pred = Nil_Pointer then Interp.Symbol_Table := Cdr; else @@ -1296,6 +1315,70 @@ Put_String (To_Thin_String_Pointer (Result)); end loop; end Deinitialize_Heap; + procedure Close_Stream (Stream: in out Stream_Pointer) is + begin + Close (Stream.all); + Stream := null; + exception + when others => + Stream := null; -- ignore exception + end Close_Stream; + + procedure Start_Named_Input_Stream (Interp: in out Interpreter_Record; + Name: in Constant_Object_String_Pointer) is + package IO_Pool is new H2.Pool (IO_Record, IO_Pointer, Interp.Storage_Pool); + + IO: IO_Pointer := null; + Stream: Stream_Pointer := null; + begin + begin + IO := IO_Pool.Allocate; + Interp.Stream.Allocate (Interp, Name, Stream); + exception + when others => + if IO /= null then + if Stream /= null then + Interp.Stream.Deallocate (Interp, Stream); + end if; + IO_Pool.Deallocate (IO); + end if; + raise; + end; + + --IO.Stream := Stream; + --IO.Pos := IO.Data'First - 1; + --IO.Last := IO.Data'First - 1; + --IO.Flags := 0; + --IO.Next := Interp.Input; + --Interp.Input := IO; + + IO.all := IO_Record'( + Stream => Stream, + Data => (others => ' '), + Pos | Last => IO.Data'First - 1, + Flags => 0, + Next => Interp.Input, + Iochar => IO_Character_Record'(End_Character, Object_Character'First) + ); + Interp.Input := IO; + end Start_Named_Input_Stream; + + procedure Stop_Named_Input_Stream (Interp: in out Interpreter_Record) is + package IO_Pool is new H2.Pool (IO_Record, IO_Pointer, Interp.Storage_Pool); + IO: IO_Pointer; + begin + pragma Assert (Interp.Input /= Interp.Base_Input'Unchecked_Access); + IO := Interp.Input; + Interp.Input := IO.Next; + + pragma Assert (IO.Stream /= null); + Close_Stream (IO.Stream); + Interp.Stream.Deallocate (Interp, IO.Stream); + IO_Pool.Deallocate (IO); + end Stop_Named_Input_Stream; + + ----------------------------------------------------------------------------- + procedure Open (Interp: in out Interpreter_Record; Initial_Heap_Size: in Heap_Size; Storage_Pool: in Storage_Pool_Pointer := null) is @@ -1382,8 +1465,8 @@ Put_String (To_Thin_String_Pointer (Result)); Interp.Root_Table := Nil_Pointer; Interp.Symbol_Table := Nil_Pointer; - Interp.Input.Stream := null; - Interp.IO := Interp.Input'Unchecked_Access; + Interp.Base_Input.Stream := null; + Interp.Input := Interp.Base_Input'Unchecked_Access; -- TODO: disallow garbage collecion during initialization. Text_IO.Put_Line ("1111111111"); @@ -1395,31 +1478,25 @@ Text_IO.Put_Line ("1111111111"); Make_Procedure_Objects; Text_IO.Put_Line ("99999"); +Text_IO.Put_Line (To_Object_String(IO_Character_Record'Size'Img)); +Text_IO.Put_Line (To_Object_String(IO_Character_Record'Max_Size_In_Storage_Elements'Img)); exception when others => Deinitialize_Heap (Interp); end Open; - procedure Close_Stream (Stream: in out Stream_Pointer) is - begin - Close (Stream.all); - Stream := null; - exception - when others => - Stream := null; -- ignore exception - end Close_Stream; - - procedure Close_All_Streams (Interp: in out Interpreter_Record) is - begin - -- TODO: close all cascaded streams if any. - if Interp.Input.Stream /= null then - Close_Stream (Interp.Input.Stream); - end if; - end Close_All_Streams; - procedure Close (Interp: in out Interpreter_Record) is begin - Close_All_Streams (Interp); + -- Destroy all unstacked named input streams + while Interp.Input /= Interp.Base_Input'Unchecked_Access loop + Stop_Named_Input_Stream (Interp); + end loop; + + if Interp.Base_Input.Stream /= null then + -- Close the main input stream. + Close_Stream (Interp.Base_Input.Stream); + end if; + Deinitialize_Heap (Interp); end Close; @@ -1458,21 +1535,18 @@ Text_IO.Put_Line ("99999"); -- if Open raised an exception, it wouldn't reach here. -- so the existing stream still remains intact. - if Interp.Input.Stream /= null then - Close_Stream (Interp.Input.Stream); + if Interp.Base_Input.Stream /= null then + Close_Stream (Interp.Base_Input.Stream); end if; - --Interp.Input := IO_Record'( - -- Stream => Stream'Unchecked_Access, - -- Data => (others => ' '), - -- Pos => Interp.Input.Data'First - 1, - -- Last => Interp.Input.Data'First - 1, - -- Flags => 0 - --); - Interp.Input.Stream := Stream'Unchecked_Access; - Interp.Input.Pos := Interp.Input.Data'First - 1; - Interp.Input.Last := Interp.Input.Data'First - 1; - Interp.Input.Flags := 0; + Interp.Base_Input := IO_Record'( + Stream => Stream'Unchecked_Access, + Data => (others => Object_Character'First), + Pos | Last => Interp.Base_Input.Data'First - 1, + Flags => 0, + Next => null, + Iochar => IO_Character_Record'(End_Character, Object_Character'First) + ); end Set_Input_Stream; --procedure Set_Output_Stream (Interp: in out Interpreter_Record; @@ -1481,60 +1555,19 @@ Text_IO.Put_Line ("99999"); -- --end Set_Output_Stream; - procedure Start_Input_Stream (Interp: in out Interpreter_Record; - Name: access Object_String) is - package IO_Pool is new H2.Pool (IO_Record, IO_Pointer, Interp.Storage_Pool); - IO: IO_Pointer; - begin - IO := IO_Pool.Allocate; - begin - Interp.Stream.Allocate (Interp, Name, IO.Stream); - exception - when others => - IO_Pool.Deallocate (IO); - raise; - end; - - begin - Open (IO.Stream.all); - exception - when others => - Interp.Stream.Deallocate (Interp, IO.Stream); - IO_Pool.Deallocate (IO); - raise; - end; - IO.Pos := IO.Data'First - 1; - IO.Last := IO.Data'First - 1; - IO.Flags := 0; - - IO.Next := Interp.IO; - Interp.IO := IO; - end Start_Input_Stream; - - procedure Stop_Input_Stream (Interp: in out Interpreter_Record) is - package IO_Pool is new H2.Pool (IO_Record, IO_Pointer, Interp.Storage_Pool); - IO: IO_Pointer; - begin - pragma Assert (Interp.IO /= Interp.Input'Unchecked_Access); - IO := Interp.IO; - Interp.IO := IO.Next; - - Interp.Stream.Deallocate (Interp, IO.Stream); - IO_Pool.Deallocate (IO); - end Stop_Input_Stream; - procedure Read (Interp: in out Interpreter_Record; Result: out Object_Pointer) is - End_Error: exception; - - function Get_Character return Object_Character is + procedure Fetch_Character is begin -- TODO: calculate Interp.Input.Row, Interp.Input.Column if Interp.Input.Pos >= Interp.Input.Last then if Interp.Input.Flags /= 0 then - -- an error has occurred previously. - raise End_Error; + -- An error has occurred or EOF has been reached previously. + -- Note calling this procedure after EOF results in an error. + Interp.Input.Iochar := (Error_Character, Object_Character'First); + --return; + raise IO_Error; end if; Interp.Input.Pos := Interp.Input.Data'First - 1; @@ -1542,27 +1575,80 @@ Text_IO.Put_Line ("99999"); Read (Interp.Input.Stream.all, Interp.Input.Data, Interp.Input.Last); exception when others => + -- The callee can raise an exception upon errors. + -- If an exception is raised, data read into the buffer + -- is also ignored. Interp.Input.Flags := Interp.Input.Flags and IO_Error_Occurred; - raise End_Error; -- TODO: change the exception name + Interp.Input.Iochar := (Error_Character, Object_Character'First); + --return; + raise IO_Error; end; if Interp.Input.Last < Interp.Input.Data'First then + -- The callee must read 0 bytes on EOF Interp.Input.Flags := Interp.Input.Flags and IO_End_Reached; - raise End_Error; + Interp.Input.Iochar := (End_Character, Object_Character'First); + return; end if; end if; Interp.Input.Pos := Interp.Input.Pos + 1; - return Interp.Input.Data(Interp.Input.Pos); - end Get_Character; + Interp.Input.Iochar := (Normal_Character, Interp.Input.Data(Interp.Input.Pos)); + end Fetch_Character; - procedure Skip_Space is + procedure Skip_Spaces is + C: IO_Character_Record renames Interp.Input.Iochar; begin - null; - end Skip_Space; + loop + exit when C.Kind /= Normal_Character; - --function Get_Token return Token_Type is - --begin - -- null; - --end Get_Token; + -- normal character + case C.Value is + when ' ' | + Object_Character'Val(Standard.Character'Pos(Standard.ASCII.HT)) | + Object_Character'Val(Standard.Character'Pos(Standard.ASCII.VT)) | + Object_Character'Val(Standard.Character'Pos(Standard.ASCII.CR)) | + Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF)) | + Object_Character'Val(Standard.Character'Pos(Standard.ASCII.FF)) => + -- white space + Fetch_Character; + + when ';' => + -- comment. consume until EOL + loop + Fetch_Character; + exit when C.Kind = Normal_Character and then + C.Value = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF)); + end loop; + + when others => + exit; + end case; + end loop; + end Skip_Spaces; + + procedure Fetch_Token is + C: IO_Character_Record renames Interp.Input.Iochar; + begin + Skip_Spaces; + if C.Kind /= Normal_Character then + Interp.Token.Kind := End_Token; + return; + end if; + + case C.Value is + when '(' => + Interp.Token := (Left_Parenthesis_Token, "("); + + when ')' => + Interp.Token := (Left_Parenthesis_Token, ")"); + + when ''' => + Interp.Token := (Single_Quote_Token, ")"); + + when others => + null; + end case; + + end Fetch_Token; procedure Read_Atom (Atom: out Object_Pointer) is begin @@ -1573,7 +1659,7 @@ Text_IO.Put_Line ("99999"); Opcode: Object_Integer; Operand: Object_Pointer; - C: Object_Character; + C: IO_Character_Record renames Interp.Input.Iochar; begin --Opcode := 1; --loop @@ -1581,14 +1667,30 @@ Text_IO.Put_Line ("99999"); -- when 1 => --end loop; loop - C := Get_Character; - Text_IO.Put (C); - end loop; + begin + Fetch_Character; + exception + when others => + TEXT_IO.New_Line; + Text_IO.Put_Line ("INPUT ERROR..."); + exit; + end; - exception - when End_Error => - TEXT_IO.New_Line; - Text_IO.Put_Line ("END OF INPUT..."); + case C.Kind is + when Normal_Character => + Text_IO.Put (C.Value); + + when End_Character => + TEXT_IO.New_Line; + Text_IO.Put_Line ("END OF INPUT..."); + exit; + + when Error_Character => + TEXT_IO.New_Line; + Text_IO.Put_Line ("INPUT ERROR..."); + exit; + end case; + end loop; end Read; procedure Print (Interp: in out Interpreter_Record; @@ -1618,11 +1720,11 @@ Text_IO.Put_Line ("99999"); raise Internal_Error; when Symbol_Object => - Text_IO.Put (To_String (Atom.Character_Slot)); + Text_IO.Put (Character_Array_To_String (Atom.Character_Slot)); when String_Object => Text_IO.Put (""""); - Text_IO.Put (To_String (Atom.Character_Slot)); + Text_IO.Put (Character_Array_To_String (Atom.Character_Slot)); Text_IO.Put (""""); when Closure_Object => @@ -1639,7 +1741,7 @@ Text_IO.Put_Line ("99999"); when Others => if Atom.Kind = Character_Object then - Text_IO.Put (To_String (Atom.Character_Slot)); + Text_IO.Put (Character_Array_To_String (Atom.Character_Slot)); else Text_IO.Put ("#NOIMPL#"); end if; @@ -1650,19 +1752,19 @@ Text_IO.Put_Line ("99999"); procedure Print_Integer is X: constant Object_Integer := Pointer_To_Integer (Atom); begin - Text_IO.Put (Object_Integer'Image (X)); + Text_IO.Put (To_Object_String(Object_Integer'Image(X))); end Print_Integer; procedure Print_Character is X: constant Object_Character := Pointer_To_Character (Atom); begin - Text_IO.Put (Object_Character'Image (X)); + Text_IO.Put (To_OBject_String(Object_Character'Image(X))); end Print_Character; procedure Print_Byte is X: constant Object_Byte := Pointer_To_Byte (Atom); begin - Text_IO.Put (Object_Byte'Image (X)); + Text_IO.Put (To_Object_String(Object_Byte'Image(X))); end Print_Byte; begin @@ -1934,7 +2036,7 @@ begin ); L := Make_Cons ( Interp.Self, - Make_Symbol (Interp.Self, "lambda"), + Make_Symbol (Interp.Self, Object_String'("lambda")), Make_Cons ( Interp.Self, P, @@ -2432,59 +2534,8 @@ Print (Interp, Operand); end Apply; procedure Read_Object is - --- 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; - --- type Input_Object_Record is --- end record; --- Read (Input_Object_Record); --- Write (Input_Object_Record); --- Close (Input_Object_Record); --- --- type Input_Object_Class_Pointer is access all Input_Object_Record'Class; --- --- type Input_Record is record --- Pos: Standard.Natural; --- Last: Standard.Natural; --- Buffer: Object_String (1 .. 1024); --- Handle: Input_Object_Class_Pointer; --- end record; --- function Get_Character return Object_Character is --- begin --- if Interp.Input.Pos >= Interp.Input.Last then --- Read (Interp.Input.Handle, Interp.Input.Buffer, Interp.Input.Last); --- Interp.Input.Pos := Interp.Input.Buffer'First - 1; --- end if; --- --- Interp.Input.Pos := Interp.Input.Pos + 1; --- return Interp.Input.Buffer(Interp.Input.Pos); --- end Get_Character; - begin null; - - --if Interp.Input.Handle = null then - -- Interp.Input.Handle := Interp.Tio (""); - -- Interp.Input.Pos := 0; - -- Interp.Input.Last := 0; - --end if; - - -- In Interp.Close() - -- if Interp.Input.Handle /= null then - -- Close (Interp.Input.Handle); - --end if; end Read_Object; begin diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 3c74ee9..ca8119d 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -37,14 +37,7 @@ with System; with System.Storage_Pools; - with Ada.Unchecked_Conversion; --- TODO: delete these after debugging -with ada.text_io; -with ada.wide_text_io; -with ada.integer_text_io; -with ada.long_integer_text_io; --- TODO: delete above after debugging package H2.Scheme is @@ -129,12 +122,11 @@ package H2.Scheme is type Object_Byte is mod 2 ** System.Storage_Unit; for Object_Byte'Size use System.Storage_Unit; - --subtype Object_Character is Standard.Wide_Character; - --subtype Object_String is Standard.Wide_String; - --package Text_IO renames Ada.Wide_Text_IO; - subtype Object_Character is Standard.Character; - subtype Object_String is Standard.String; - package Text_IO renames Ada.Text_IO; + subtype Object_Character is Standard.Wide_Character; + subtype Object_String is Standard.Wide_String; + + type Object_String_Pointer is access all Object_String; + type Constant_Object_String_Pointer is access constant Object_String; type Object_Byte_Array is array (Object_Size range <>) of Object_Byte; type Object_Character_Array is array (Object_Size range <>) of Object_Character; @@ -307,8 +299,8 @@ package H2.Scheme is type Stream_Allocator is access procedure (Interp: in out Interpreter_Record; - Name: access Object_String; - Result: out Stream_Pointer); + Name: Constant_Object_String_Pointer; + Result: out Stream_Pointer); type Stream_Deallocator is access procedure (Interp: in out Interpreter_Record; @@ -322,15 +314,23 @@ package H2.Scheme is type IO_Record; type IO_Pointer is access all IO_Record; + type Character_Kind is (End_Character, Normal_Character, Error_Character); + type IO_Character_Record is record + Kind: Character_Kind := End_Character; + Value: Object_Character := Object_Character'First; + end record; + --pragma Pack (IO_Character_Record); + type IO_Record is record --type IO_Record is limited record Stream: Stream_Pointer := null; - --Data: Object_String(1..2048) := (others => ' '); - Data: Object_String(1..5) := (others => ' '); + --Data: Object_String(1..2048) := (others => Object_Character'First); + Data: Object_String(1..5) := (others => Object_Character'First); Last: Standard.Natural := 0; Pos: Standard.Natural := 0; Flags: IO_Flags := 0; -- EOF, ERROR - Next: IO_Pointer; + Next: IO_Pointer := null; + Iochar: IO_Character_Record; -- the last character read. end record; @@ -437,6 +437,18 @@ private Next: Object_Pointer := Nil_Pointer; end record; + type Token_Kind is (End_Token, + Identifier_Token, + Left_Parenthesis_Token, + Right_Parenthesis_Token, + Single_Quote_Token + ); + + type Token_Record is record + Kind: Token_Kind; + Value: Object_String; + end record; + --type Interpreter_Record is tagged limited record type Interpreter_Record is limited record --Self: Interpreter_Pointer := null; @@ -457,9 +469,10 @@ private R: Register_Record; - -- TODO: Buffer_Record needs to be stacked to handle "load". - Input: aliased IO_Record; - IO: IO_Pointer := null; + Base_Input: aliased IO_Record; + Input: IO_Pointer := null; + + Token: Token_Record; end record; end H2.Scheme; diff --git a/lib/h2.ads b/lib/h2.ads index 38b714d..88b5a42 100644 --- a/lib/h2.ads +++ b/lib/h2.ads @@ -2,8 +2,6 @@ with System.Storage_Pools; package H2 is - --subtype Character is Standard.Wide_Character; - type Storage_Pool_Pointer is access all System.Storage_Pools.Root_Storage_Pool'Class;