29 files changed, 21 insertions(+), 5081 deletions(-)
M janusada/prepare.bat
M janusada/update.bat
R src/hauki-containers-doubly_linked_lists.adb =>
R src/hauki-containers-doubly_linked_lists.ads =>
R src/hauki-containers.ads =>
R src/hauki.ads =>
M src/http.adb
M src/http.ads
R src/input.adb =>
R src/input.ads =>
R src/json-data.adb =>
R src/json-data.ads =>
R src/json-lexer.adb =>
R src/json-lexer.ads =>
R src/json-parser.adb =>
R src/json-parser.ads =>
R src/json.ads =>
R src/multi_precision_integers-check.adb =>
R src/multi_precision_integers-check.ads =>
R src/multi_precision_integers-io.adb =>
R src/multi_precision_integers-io.ads =>
R src/multi_precision_integers.adb =>
R src/multi_precision_integers.ads =>
M src/oauth-easy.adb
M src/tweet_parser.adb
M src/tweet_parser.ads
M src/twit2.adb
M src/twitter.adb
M src/twitter.ads
M janusada/prepare.bat +6 -4
@@ 1,6 1,7 @@
set januspath=C:\Jnt312a\rts\console
set ahvenpath=C:\work\ahven-h\lib_obj
+set haukipath=C:\work\hauki\lib_obj
set jdaughterpath=c:\work\jdaughter\lib_obj
set curlpath=c:\work\curl\obj
@@ 8,10 9,11 @@ REM *** SOURCE ***
del /q build\*.*
mkdir build
jmanager Add_Project (build,LADYBIRD)
-jmanager Add_Link (build,LADYBIRD,%januspath%, JNT_RTS_CONSOLE)
-jmanager Add_Link (build,LADYBIRD,%jdaughterpath%, JDLib)
-jmanager Add_Link (build,LADYBIRD,%jdaughterpath%, JDLib)
-jmanager Add_Link (build,LADYBIRD,%curlpath%, curl)
+jmanager Add_Link (build,LADYBIRD, %januspath%, JNT_RTS_CONSOLE)
+jmanager Add_Link (build,LADYBIRD, %jdaughterpath%, JDLib)
+jmanager Add_Link (build,LADYBIRD, %ahvenpath%, AhvenLib)
+jmanager Add_Link (build,LADYBIRD, %haukipath%, HaukiLib)
+jmanager Add_Link (build,LADYBIRD, %curlpath%, curl)
M janusada/update.bat +1 -1
@@ 1,3 1,3 @@
cd src
-corder twit2 /pbuild/l'ads'/n'adb'/t/w/k255/js'jbind'/jb'/t/l/YLLIBCMT'/b'ctst.bat'/r..\build
+corder twit2 /pLADYBIRD/l'ads'/n'adb'/t/w/k255/js'jbind'/jb'/t/l/YLLIBCMT'/b'ctst.bat'/r..\build
cd ..
R src/hauki-containers-doubly_linked_lists.adb => +0 -795
@@ 1,795 0,0 @@
---
--- Copyright (c) 2006-2008 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-
-with Ada.Unchecked_Deallocation;
-
-package body Hauki.Containers.Doubly_Linked_Lists is
-
- function Cursor_In_Container (Container : List; Position : Cursor)
- return Boolean
- is
- begin
- return Position.First_Item = Container.First;
- end Cursor_In_Container;
-
- function Create_Nodes (Count : Count_Type; New_Item : Element_Type)
- return Node_Access is
- Current : Node_Access := null;
- First : Node_Access := null;
- Counter : Count_Type := 0;
- begin
- if Count = 0 then
- return null;
- end if;
-
- loop
- exit when Counter = Count;
- Current :=
- new Node'(Prev => Current, Next => null, Data => New_Item);
- if First = null then
- First := Current;
- else
- Current.Prev.Next := Current;
- end if;
- First.Prev := Current;
- Counter := Counter + 1;
- end loop;
- return First;
- exception
- when Storage_Error =>
- -- Storage error, removing allocated nodes
- Current := First;
- loop
- exit when Current = null;
- First := Current.Next;
- Remove (First);
- Current := First;
- end loop;
- raise;
- end Create_Nodes;
-
- procedure Remove (Ptr : Node_Access) is
- procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Access);
- My_Ptr : Node_Access := Ptr;
- begin
- Ptr.Next := null;
- Ptr.Prev := null;
- Free (My_Ptr);
- end Remove;
-
- function "=" (Left, Right : List) return Boolean is
- Left_C, Right_C : Cursor;
- begin
- if Left.Size /= Right.Size then
- return False;
- end if;
-
- Left_C := First (Left);
- Right_C := First (Right);
-
- loop
- exit when Left_C = No_Element or Right_C = No_Element;
- if Left_C.Ptr.Data /= Right_C.Ptr.Data then
- return False;
- end if;
-
- Next (Left_C);
- Next (Right_C);
- end loop;
-
- return True;
- end "=";
-
- procedure Delete (Container : in out List;
- Position : Cursor;
- Count : Count_Type := 1) is
- Current : Node_Access;
- First_Valid : Node_Access := Container.First;
- Prev_Valid : Node_Access := Container.First;
- Counter : Count_Type := 0;
- begin
- if Container.Size = 0 then
- raise Program_Error;
- elsif Position = No_Element then
- raise Constraint_Error;
- elsif Count = 0 then
- return;
- end if;
-
- Current := Position.Ptr;
-
- if Current = Container.First then
- loop
- exit when Counter = Count or Current = null;
- First_Valid := Current.Next;
- Remove (Current);
- Current := First_Valid;
- Counter := Counter + 1;
- end loop;
- Container.First := First_Valid;
- if Container.First = null then
- Container.Last := null;
- else
- Container.First.Prev := null;
- end if;
- elsif Current = Container.Last then
- Current := Container.Last;
- Container.Last := Current.Prev;
- Container.Last.Next := null;
- Remove (Current);
- Counter := 1;
- else
- Prev_Valid := Current.Prev;
- loop
- exit when Counter = Count or Current = null;
- First_Valid := Current.Next;
- Remove (Current);
- Current := First_Valid;
- Counter := Counter + 1;
- end loop;
- Prev_Valid.Next := First_Valid;
- if First_Valid /= null then
- First_Valid.Prev := Prev_Valid;
- else
- Container.Last := Prev_Valid;
- end if;
- end if;
-
- Container.Size := Container.Size - Counter;
- end Delete;
-
- procedure Insert (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Count : Count_Type := 1) is
- New_Position : Cursor;
- begin
- Insert (Container, Before, New_Item, New_Position, Count);
- end Insert;
-
- procedure Insert (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor;
- Count : Count_Type := 1) is
- New_Node : Node_Access;
- Last_New_Node : Node_Access;
- begin
- if Count = 0 then
- Position := No_Element;
- return;
- end if;
-
- if Before /= No_Element and
- not Cursor_In_Container (Container, Before) then
- raise Program_Error;
- end if;
-
- New_Node := Create_Nodes (Count, New_Item);
- -- New_Node.Prev points to the last of the created nodes.
- Last_New_Node := New_Node.Prev;
- New_Node.Prev := null;
-
- -- Note: Order of the assignments matter!
- -- List empty?
- if Container.First = null then
- Container.First := New_Node;
- Container.Last := Last_New_Node;
- Container.First.Prev := null;
- -- Inserting at the beginning of the list?
- elsif Before.Ptr = Container.First then
- Last_New_Node.Next := Container.First;
- Container.First.Prev := Last_New_Node;
- Container.First := New_Node;
- Container.First.Prev := null;
- -- Inserting at the end of the list?
- elsif Before.Ptr = null then
- Container.Last.Next := New_Node;
- New_Node.Prev := Container.Last;
- Container.Last := Last_New_Node;
- -- Inserting in the middle of the list
- else
- declare
- Previous_Node : Node_Access := Before.Ptr.Prev;
- begin
- Previous_Node.Next := New_Node;
- Before.Ptr.Prev := Last_New_Node;
- Last_New_Node.Next := Before.Ptr;
- New_Node.Prev := Previous_Node;
- end;
- end if;
- Position := (Ptr => New_Node, First_Item => Container.First);
- Container.Size := Container.Size + Count;
- end Insert;
-
--- procedure Insert (Container : in out List;
--- Before : in Cursor;
--- Position : out Cursor;
--- Count : in Count_Type := 1) is
--- New_Element : Element_Type := Element_Type'(Element_Type);
--- begin
--- Insert (Container => Container,
--- Before => Before,
--- New_Item => New_Element,
--- Position => Position,
--- Count => Count);
--- end Insert;
-
- procedure Prepend (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type := 1) is
- begin
- Insert (Container, First (Container), New_Item, Count);
- end Prepend;
-
- procedure Append (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type := 1) is
- begin
- Insert (Container, No_Element, New_Item, Count);
- end Append;
-
- procedure Clear (Container : in out List) is
- Current_Node : Node_Access := Container.First;
- Next_Node : Node_Access := null;
- begin
- while Current_Node /= null loop
- Next_Node := Current_Node.Next;
- Remove (Current_Node);
- Current_Node := Next_Node;
- end loop;
-
- Container.First := null;
- Container.Last := null;
- Container.Size := 0;
- end Clear;
-
- procedure Delete_First (Container : in out List) is
- Temp_Node : Node_Access;
- begin
- if Container.Size = 0 then
- raise List_Empty;
- end if;
-
- Temp_Node := Container.First;
- Container.First := Container.First.Next;
- if Container.First /= null then
- Container.First.Prev := null;
- else
- Container.Last := null;
- end if;
-
- Remove (Temp_Node);
- Container.Size := Container.Size - 1;
- end Delete_First;
-
- procedure Delete_Last (Container : in out List) is
- Temp_Node : Node_Access;
- begin
- if Container.Size = 0 then
- raise List_Empty;
- end if;
-
- Temp_Node := Container.Last;
-
- Container.Last := Temp_Node.Prev;
- if Container.Last /= null then
- Container.Last.Next := null;
- else
- Container.First := null;
- end if;
-
- Remove (Temp_Node);
- Container.Size := Container.Size - 1;
- end Delete_Last;
-
- procedure Splice (Target : in out List;
- Before : in Cursor;
- Source : in out List;
- Position : in out Cursor) is
- Removable : Node_Access;
- Prev_Node : Node_Access;
- Next_Node : Node_Access;
- Before_Node : Node_Access := Before.Ptr;
- begin
- if Position = No_Element then
- raise Constraint_Error;
- elsif Target.First = Source.First and Before = Position then
- return;
- end if;
-
- Removable := Position.Ptr;
-
- -- Remove node from Source list
- Source.Size := Source.Size - 1;
- if Removable = Source.First and Removable = Source.Last then
- Source.First := null;
- Source.Last := null;
- elsif Removable = Source.First then
- Source.First := Removable.Next;
- Source.First.Prev := null;
- elsif Removable = Source.Last then
- Source.Last := Removable.Prev;
- Source.Last.Next := null;
- else
- Prev_Node := Removable.Prev;
- Next_Node := Removable.Next;
- Prev_Node.Next := Next_Node;
- Next_Node.Prev := Prev_Node;
- end if;
-
- -- Add node to the Target list
- Target.Size := Target.Size + 1;
- if Target.Size = 1 then
- Removable.Prev := null;
- Removable.Next := null;
- Target.First := Removable;
- Target.Last := Removable;
- elsif Before = No_Element then
- Removable.Prev := Target.Last;
- Removable.Next := null;
- Target.Last.Next := Removable;
- Target.Last := Removable;
- elsif Before_Node = Target.First then
- Removable.Prev := null;
- Removable.Next := Target.First;
- Target.First.Prev := Removable;
- Target.First := Removable;
- else
- Removable.Prev := Before_Node.Prev;
- Removable.Next := Before_Node;
- Before_Node.Prev.Next := Removable;
- Before_Node.Prev := Removable;
- end if;
- Position := (Ptr => Removable, First_Item => Target.First);
- end Splice;
-
- procedure Splice (Target : in out List;
- Before : in Cursor;
- Source : in out List) is
- New_Node : constant Node_Access := Source.First;
- begin
- if Source.Size = 0 or Source.First = Target.First then
- return;
- end if;
- if Before = No_Element then
- if Target.Last = null then
- Target.First := New_Node;
- else
- Target.Last.Next := New_Node;
- New_Node.Prev := Target.Last;
- end if;
- Target.Last := Source.Last;
- else
- -- Target list is empty?
- if Target.First = null then
- Target.First := New_Node;
- Target.Last := Source.Last;
- Target.First.Prev := null;
- -- We insert at the beginning of the list?
- elsif Before.Ptr = Target.First then
- Source.Last.Next := Target.First;
- Target.First.Prev := Source.Last;
- Target.First := New_Node;
- Target.First.Prev := null;
- else
- -- New order will be:
- -- [previous_node] [new_node] ... [source.last] [target.first]
- declare
- Previous_Node : Node_Access := Before.Ptr.Prev;
- begin
- Previous_Node.Next := New_Node;
- Before.Ptr.Prev := Source.Last;
- Source.Last.Next := Before.Ptr;
- New_Node.Prev := Previous_Node;
- end;
- end if;
- end if;
- Target.Size := Target.Size + Source.Size;
-
- Source.First := null;
- Source.Last := null;
- Source.Size := 0;
- end Splice;
-
- procedure Replace_Element (Container : in out List;
- Position : Cursor;
- New_Item : Element_Type) is
- begin
- if Position = No_Element then
- raise Constraint_Error;
- end if;
-
- if not Cursor_In_Container (Container, Position) then
- raise Program_Error;
- end if;
-
- Position.Ptr.Data := New_Item;
- end Replace_element;
-
- function Is_Empty (Container : List) return Boolean is
- begin
- return Container.Size = 0;
- end Is_Empty;
-
- function First (Container : List) return Cursor is
- begin
- if Container.Size = 0 then
- return (Ptr => null, First_Item => null);
- end if;
-
- return (Ptr => Container.First, First_Item => Container.First);
- end First;
-
- function First_Element (Container : List) return Element_Type is
- begin
- return Container.First.Data;
- end First_Element;
-
- function Last (Container : List) return Cursor is
- begin
- if Container.Size = 0 then
- return (Ptr => null, First_Item => null);
- end if;
-
- return (Ptr => Container.Last, First_Item => Container.First);
- end Last;
-
- function Next (Position : Cursor) return Cursor is
- begin
- if Position.Ptr = null or else Position.Ptr.Next = null then
- return No_Element;
- end if;
- return (Ptr => Position.Ptr.Next,
- First_Item => Position.First_Item);
- end Next;
-
- procedure Next (Position : in out Cursor) is
- begin
- Position := Next (Position);
- end Next;
-
- function Previous (Position : Cursor) return Cursor is
- begin
- if Position.Ptr = null or else Position.Ptr.Prev = null then
- return No_Element;
- end if;
- return (Ptr => Position.Ptr.Prev,
- First_Item => Position.First_Item);
- end Previous;
-
- procedure Previous (Position : in out Cursor) is
- begin
- Position := Previous (Position);
- end Previous;
-
- function Find (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element)
- return Cursor is
-
- Current : Node_Access := null;
- begin
- if Position.Ptr = null then
- Current := Container.First;
- else
- Current := Position.Ptr;
- end if;
- loop
- exit when Current = null;
- if Current.Data = Item then
- return (Ptr => Current, First_Item => Container.First);
- end if;
- Current := Current.Next;
- end loop;
-
- return No_Element;
- end Find;
-
- function Element (Position : Cursor) return Element_Type is
- begin
- if Position = No_Element then
- raise Constraint_Error;
- end if;
- return Position.Ptr.Data;
- end Element;
-
- function Length (Container : List) return Count_Type is
- begin
- return Container.Size;
- end Length;
-
- procedure Move (Target : in out List; Source : in out List) is
- begin
- Clear (Target);
- if Source.Size = 0 then
- return;
- end if;
-
- Target.First := Source.First;
- Target.Last := Source.Last;
- Target.Size := Source.Size;
-
- -- No need to release Source's memory
- -- because all nodes are transferred to Target
- Source.Last := null;
- Source.First := null;
- Source.Size := 0;
- end Move;
-
- procedure Initialize (Object : in out List) is
- begin
- Object.Last := null;
- Object.First := null;
- Object.Size := 0;
- end Initialize;
-
- procedure Finalize (Object : in out List) is
- begin
- Clear (Object);
- end Finalize;
-
- procedure Adjust (Object : in out List) is
- Target_Last : Node_Access := null;
- Target_First : Node_Access := null;
- Current : Node_Access := Object.First;
- New_Node : Node_Access;
- begin
- while Current /= null loop
- New_Node := new Node'(Data => Current.Data,
- Next => null, Prev => Target_Last);
-
- if Target_Last = null then
- Target_Last := New_Node;
- Target_First := New_Node;
- else
- Target_Last.Next := New_Node;
- Target_Last := New_Node;
- end if;
-
- Current := Current.Next;
- end loop;
- Object.First := Target_First;
- Object.Last := Target_Last;
- end Adjust;
-
- procedure Query_Element
- (Position : Cursor;
- Process : Query_Proc) is
- begin
- if Position = No_Element then
- raise Constraint_Error;
- end if;
- Process.all (Position.Ptr.all.Data);
- end Query_Element;
-
- procedure Update_Element
- (Container : in out List;
- Position : Cursor;
- Process : Update_Proc) is
- begin
- if Position = No_Element then
- raise Constraint_Error;
- elsif Container.First /= Position.First_item then
- raise Program_Error;
- end if;
-
- Process.all (Position.Ptr.all.Data);
- end Update_Element;
-
- procedure Assign (Target : in out List;
- Source : List) is
- begin
- if Target.First = Source.First then
- return;
- end if;
-
- Target := Source;
- end Assign;
-
- function Copy (Source : List) return List is
- begin
- return Source; -- XXX is this enough or should we
- -- create a temporary copy also.
- end Copy;
-
- procedure Swap (Container : in out List;
- I, J : Cursor) is
- Temp : Element_Type;
- begin
- if I = No_Element or J = No_Element then
- raise Constraint_Error;
- elsif I.First_Item /= Container.First or
- J.First_Item /= Container.First then
- raise Program_Error;
- elsif I.Ptr = J.Ptr then
- return;
- end if;
-
- Temp := I.Ptr.Data;
- I.Ptr.Data := J.Ptr.Data;
- J.Ptr.Data := Temp;
- end Swap;
-
- procedure Swap_Links (Container : in out List;
- I, J : in Cursor) is
- I_Is_First : constant Boolean := I.Ptr = Container.First;
- I_Is_Last : constant Boolean := I.Ptr = Container.Last;
- J_Is_First : constant Boolean := J.Ptr = Container.First;
- J_Is_Last : constant Boolean := J.Ptr = Container.Last;
-
- Prev_Link, Next_Link : Node_Access;
- begin
- if I = No_Element or J = No_Element then
- raise Constraint_Error;
- elsif I.Ptr = J.Ptr then
- return;
- end if;
-
- Prev_Link := I.Ptr.Prev;
- Next_Link := I.Ptr.Next;
-
- if I.Ptr.Prev /= null then
- I.Ptr.Prev.Next := J.Ptr;
- end if;
- if I.Ptr.Next /= null then
- I.Ptr.Next := J.Ptr;
- end if;
- I.Ptr.Prev := J.Ptr.Prev;
- I.Ptr.Next := J.Ptr.Next;
-
- if J.Ptr.Prev /= null then
- J.Ptr.Prev.Next := I.Ptr;
- end if;
- if J.Ptr.Next /= null then
- J.Ptr.Next.Prev := I.Ptr;
- end if;
- J.Ptr.Prev := Prev_Link;
- J.Ptr.Next := Next_Link;
-
- if I_Is_First then
- Container.First := J.Ptr;
- end if;
- if I_Is_Last then
- Container.Last := J.Ptr;
- end if;
- if J_Is_First then
- Container.First := I.Ptr;
- end if;
- if J_Is_Last then
- Container.Last := I.Ptr;
- end if;
- end Swap_Links;
-
- function Contains (Container : List;
- Item : Element_Type) return Boolean is
- Current : Node_Access := Container.First;
- begin
- loop
- exit when Current = null;
- if Current.Data = Item then
- return True;
- end if;
- Current := Current.Next;
- end loop;
- return False;
- end Contains;
-
- function Has_Element (Position : Cursor) return Boolean is
- begin
- return Position.Ptr /= null;
- end Has_Element;
-
- procedure Iterate (Container : List; Process : Iterate_Proc) is
- Current : Node_Access := Container.First;
- begin
- loop
- exit when Current = null;
- Process.all (Cursor'(Current, Container.First));
- Current := Current.Next;
- end loop;
- end Iterate;
-
- procedure Reverse_Iterate (Container : List; Process : Iterate_Proc) is
- Current : Node_Access := Container.Last;
- begin
- loop
- exit when Current = null;
- Process.all (Cursor'(Current, Container.First));
- Current := Current.Prev;
- end loop;
- end Reverse_Iterate;
-
- package body Generic_Sorting is
- function Is_Sorted (Container : List) return Boolean is
- Pos : Cursor := First (Container);
- Next_Pos : Cursor;
- begin
- loop
- exit when Pos = No_Element;
- Next_Pos := Next (Pos);
- exit when Next_Pos = No_Element;
- if not (Element (Pos) < Element (Next_Pos)) then
- return False;
- end if;
-
- Pos := Next_Pos;
- end loop;
- return True;
- end Is_Sorted;
-
- procedure Sort (Container : in out List) is
- Left : List := Empty_List;
- Middle : constant Count_Type := Length (Container) / 2;
- Pos : Cursor;
- begin
- if Length (Container) < 2 then
- return;
- end if;
-
- for I in Count_Type range 1 .. Middle loop
- Pos := First (Container);
- Splice (Target => Left,
- Before => No_Element,
- Source => Container,
- Position => Pos);
- end loop;
-
- Sort (Left);
- Sort (Container);
- Merge (Left, Container);
- Move (Target => Container, Source => Left);
- end Sort;
-
- procedure Merge (Target : in out List;
- Source : in out List) is
- Result : List := Empty_List;
- Pos : Cursor;
- begin
- loop
- exit when Length (Target) = 0 or Length (Source) = 0;
- if First_Element (Target) < First_Element (Source) then
- Pos := First (Target);
- Splice (Target => Result,
- Before => No_Element,
- Source => Target,
- Position => Pos);
- else
- Pos := First (Source);
- Splice (Target => Result,
- Before => No_Element,
- Source => Source,
- Position => Pos);
- end if;
- end loop;
-
- if Length (Target) > 0 then
- Splice (Target => Result,
- Before => No_Element,
- Source => Target);
- else
- Splice (Target => Result,
- Before => No_Element,
- Source => Source);
- end if;
-
- Move (Target => Target,
- Source => Result);
- end Merge;
- end Generic_Sorting;
-
-end Hauki.Containers.Doubly_Linked_Lists;
-
R src/hauki-containers-doubly_linked_lists.ads => +0 -305
@@ 1,305 0,0 @@
---
--- Copyright (c) 2006-2008 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-
-with Ada.Finalization;
-
-generic
- type Element_Type is private;
- with function "=" (Left, Right : Element_Type)
- return Boolean is <>;
-package Hauki.Containers.Doubly_Linked_Lists is
- -- pragma Preelaborate(Doubly_Linked_Lists);
-
- type Cursor is private;
-
- List_Empty : exception;
- Out_Of_Range : exception;
- Invalid_Cursor : exception;
-
- type List is tagged private;
- -- List is a Controlled type. You can safely copy it.
- -- Although, notice that if you have a list of pointers (access types),
- -- only the pointers are copied, not the objects they point at.
-
- Empty_List : constant List;
- -- A list with zero elements.
- -- For example, can be used for initialization.
-
- No_Element : constant Cursor;
-
- function "=" (Left, Right : List) return Boolean;
- -- Compares the lists.
- --
- -- Time: O(N)
-
- function Length (Container : List) return Count_Type;
- -- Return the size of the list.
- --
- -- Time: O(1)
-
- function Is_Empty (Container : List) return Boolean;
- -- Is the list empty?
- --
- -- Time: O(1)
-
- procedure Clear (Container : in out List);
- -- Remove all elements from the list.
- --
- -- Time: O(N)
-
- function Element (Position : Cursor) return Element_Type;
- -- Return element pointed by the iterator.
- --
- -- Time: O(1)
-
- procedure Replace_Element (Container : in out List;
- Position : Cursor;
- New_Item : Element_Type);
- -- Replace the element poited by the iterator with the given item.
- --
- -- Time: O(1)
-
- type Query_Proc is access procedure (Element : Element_Type);
-
- procedure Query_Element
- (Position : Cursor;
- Process : Query_Proc);
- -- Call the given procedure with the element pointed by the cursor.
- --
- -- Time: O(1)
-
- type Update_Proc is access procedure (Element : in out Element_Type);
-
- procedure Update_Element
- (Container : in out List;
- Position : Cursor;
- Process : Update_Proc);
- -- Call the given procedure with the element pointed by the cursor.
- -- The process is expected to modify the given element.
- --
- -- Time: O(1)
-
- procedure Assign (Target : in out List;
- Source : List);
- -- Assign the contents of the source to the Target.
- -- If Target and Source denote the same object,
- -- the procedure does nothing.
- --
- -- Time: O(N)
-
- function Copy (Source : List) return List;
- -- Returns a copy of Source.
- --
- -- Time: O(N)
-
- procedure Move (Target : in out List; Source : in out List);
- -- Move all elements from the Source list to the Target list.
- -- The Target list is cleared before move.
- --
- -- Time: O(1)
-
- procedure Insert (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Count : Count_Type := 1);
- -- Insert an item before the cursor.
- --
- -- Time: O(1) or actually O(Count)
-
- procedure Insert (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor;
- Count : Count_Type := 1);
- -- Insert one or more items before the cursor.
- -- Set Position to point to the first element.
- --
- -- Time: O(1) or actually O(Count)
-
--- procedure Insert (Container : in out List;
--- Before : in Cursor;
--- Position : out Cursor;
--- Count : in Count_Type := 1);
-
- procedure Append (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type := 1);
- -- Append an element(s) at the end of the list.
- --
- -- Time: O(1)
-
- procedure Prepend (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type := 1);
- -- Prepend an element at the beginning of the list.
- --
- -- Time: O(1)
-
- procedure Delete (Container : in out List;
- Position : Cursor;
- Count : Count_Type := 1);
- -- Remove an elemenent pointed by the iterator.
- --
- -- Time: O(1)
-
- procedure Delete_First (Container : in out List);
- -- Remove the first element from the list.
- --
- -- Time: O(1)
-
- procedure Delete_Last (Container : in out List);
- -- Remove the last element from the list.
- --
- -- Time: O(1)
-
- procedure Swap (Container : in out List;
- I, J : Cursor);
- -- Swap elements pointed by I and J
- --
- -- Time: O(1)
-
- procedure Swap_Links (Container : in out List;
- I, J : in Cursor);
- -- Swap nodes I and J.
- --
- -- Time: O(1)
-
- procedure Splice (Target : in out List;
- Before : in Cursor;
- Source : in out List;
- Position : in out Cursor);
- -- Move element designated by Position from Source to Target and
- -- place them in front of element pointed by Before.
- -- Update Position to point to the node in Target.
-
- procedure Splice (Target : in out List;
- Before : in Cursor;
- Source : in out List);
- -- Move all elements from Source to Target and
- -- place them in front of element pointed by Before.
-
- function First (Container : List) return Cursor;
- -- Return an iterator to the first element of the list.
- --
- -- Time: O(1)
-
- function First_Element (Container : List) return Element_Type;
- -- Return the first element of the list.
- --
- -- Time: O(1)
-
- function Last (Container : List) return Cursor;
- -- Return an iterator to the last element of the list.
- --
- -- Time: O(1)
-
- function Next (Position : Cursor) return Cursor;
- -- Move the iterator to point to the next element on the list.
- --
- -- Time: O(1)
-
- procedure Next (Position : in out Cursor);
- -- Move the iterator to point to the next element on the list.
- --
- -- Time: O(1)
-
- function Previous (Position : Cursor) return Cursor;
- -- Move the iterator to point to the previous element on the list.
- --
- -- Time: O(1)
-
- procedure Previous (Position : in out Cursor);
- -- Move the iterator to point to the previous element on the list.
- --
- -- Time: O(1)
-
- function Find (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element)
- return Cursor;
- -- Find element from the list.
- --
- -- Time: O(N)
-
- function Contains (Container : List;
- Item : Element_Type) return Boolean;
- -- Return True if Container contains the specified Item.
- --
- -- Time: O(N)
-
- function Has_Element (Position : Cursor) return Boolean;
- -- Return True if Position points to a valid Element.
- --
- -- Time: O(1)
-
- type Iterate_Proc is access procedure (Position : Cursor);
-
- procedure Iterate (Container : List; Process : Iterate_Proc);
- -- Iterate through the Container and call Process for each element.
-
- procedure Reverse_Iterate (Container : List; Process : Iterate_Proc);
- -- Iterate through the Container in reverse order
- -- and call Process for each element.
-
- generic
- with function "<" (Left, Right : Element_Type)
- return Boolean is <>;
- package Generic_Sorting is
- function Is_Sorted (Container : List) return Boolean;
- procedure Sort (Container : in out List);
- procedure Merge (Target : in out List;
- Source : in out List);
- end Generic_Sorting;
-private
- type Node;
- type Node_Access is access Node;
- type Cursor is record
- Ptr : Node_Access;
- First_Item : Node_Access;
- end record;
-
- function Cursor_In_Container (Container : List; Position : Cursor)
- return Boolean;
-
- function Create_Nodes (Count : Count_Type; New_Item : Element_Type)
- return Node_Access;
-
- procedure Remove (Ptr : Node_Access);
- -- A procedure to release memory pointed by Ptr.
-
- type Node is record
- Data : Element_Type;
- Next : Node_Access := null;
- Prev : Node_Access := null;
- end record;
-
- type List is new Ada.Finalization.Controlled with record
- First : Node_Access := null;
- Last : Node_Access := null;
- Size : Count_Type := 0;
- end record;
-
- procedure Initialize (Object : in out List);
- procedure Finalize (Object : in out List);
- procedure Adjust (Object : in out List);
-
- Empty_List : constant List :=
- (Ada.Finalization.Controlled with First => null,
- Last => null,
- Size => 0);
-
- No_Element : constant Cursor := (Ptr => null, First_Item => null);
-end Hauki.Containers.Doubly_Linked_Lists;
R src/hauki-containers.ads => +0 -23
@@ 1,23 0,0 @@
---
--- Copyright (c) 2008 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-
-package Hauki.Containers is
- pragma Pure (Containers);
-
- type Hash_Type is mod 2**32;
-
- type Count_Type is range 0 .. 2**31-1;
-end Hauki.Containers;
R src/hauki.ads => +0 -19
@@ 1,19 0,0 @@
---
--- Copyright (c) 2006-2008 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-
-package Hauki is
- pragma Pure (Hauki);
-end Hauki;
M src/http.adb +1 -1
@@ 6,7 6,7 @@ with CURL.Easy;
with CURL.Options;
with CURL.Codes;
with CURL.SList;
-with Charbuf;
+
package body HTTP is
use type CURL.Codes.CURL_Code_Type;
M src/http.ads +3 -1
@@ 2,9 2,11 @@ with Ada.Strings.Unbounded;
use Ada.Strings.Unbounded;
-with Charbuf;
+with Hauki.Charbuf;
package HTTP is
+ use Hauki;
+
HTTP_Error : exception;
procedure Get_Page (URL : String; Contents : out Charbuf.Char_Buffer);
R src/input.adb => +0 -153
@@ 1,153 0,0 @@
---
--- Copyright (c) 2009 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-with Ada.Text_IO; use Ada.Text_IO;
-
-package body Input is
-
- -- File stream
-
- procedure Open (File : in out File_Stream; Filename : String)
- is
- begin
- File_IO.Open (File => File.Source_File,
- Mode => File_IO.In_File,
- Name => Filename);
- File.Filename := To_Unbounded_String (Filename);
- end Open;
-
- procedure Close (File : in out File_Stream)
- is
- begin
- File_IO.Close (File.Source_File);
- end Close;
-
- procedure Get
- (File : in out File_Stream; Char : out Character; Status : out Boolean)
- is
- Data : Character := ' ';
- begin
- if Length (File.Buffer) > 0 then
- Data := Element (File.Buffer, Length (File.Buffer));
- Head (File.Buffer, Length (File.Buffer) - 1);
- Char := Data;
- Status := True;
- if Char = Character'Val(10) then
- File.Line_Number := File.Line_Number + 1;
- end if;
- elsif File_IO.End_Of_File (File.Source_File) then
- Status := False;
- else
- File_IO.Read (File.Source_File, Data);
- Char := Data;
- Status := True;
- end if;
- end Get;
-
- procedure Put (File : in out File_Stream; Char : in Character)
- is
- begin
- if Char = Character'Val(10) and
- File.Line_Number > Positive'First then
- File.Line_Number := File.Line_Number - 1;
- end if;
- Append (File.Buffer, Char);
- end Put;
-
- function End_Of_File (File : in File_Stream)
- return Boolean is
- begin
- return File_IO.End_Of_File (File.Source_File);
- end End_Of_File;
-
- function Name (File : in File_Stream)
- return Unbounded_String is
- begin
- return File.Filename;
- end Name;
-
- function Line (File : in File_Stream) return Natural is
- begin
- return File.Line_Number;
- end Line;
-
- -- Unbounded_String stream
-
- procedure Open (Buffer : in out Unbounded_String_Stream;
- Data : Charbuf.Char_Buffer) is
- begin
- Put_Line ("Open begin");
- for I in reverse Long_Integer range 1 .. Length (Data) loop
- -- Put_Line ("Append " & I'Img);
- Append (Buffer.Buffer, Element (Data, I));
- end loop;
- Put_Line ("Open end");
- end Open;
-
- procedure Close (Buffer : in out Unbounded_String_Stream) is
- begin
- -- Buffer.Buffer := Null_Unbounded_String;
- null;
- end Close;
-
- procedure Get
- (File : in out Unbounded_String_Stream;
- Char : out Character; Status : out Boolean)
- is
- Data : Character := ' ';
- begin
- if Length (File.Buffer) > 0 then
- Data := Element (File.Buffer, Length (File.Buffer));
- Head (File.Buffer, Length (File.Buffer) - 1);
- Char := Data;
- Status := True;
- Put_Line ("Source_Code.Get: " & Data);
- if Char = Character'Val(10) then
- File.Line_Number := File.Line_Number + 1;
- end if;
- else
- Status := False;
- end if;
- end Get;
-
- procedure Put
- (File : in out Unbounded_String_Stream;
- Char : in Character) is
- begin
- if Char = Character'Val(10) then
- File.Line_Number := File.Line_Number - 1;
- end if;
- Put_Line ("Source_Code.Put: " & Char);
- Append (File.Buffer, Char);
- end Put;
-
- function End_Of_File (File : in Unbounded_String_Stream)
- return Boolean is
- begin
- return Length (File.Buffer) = 0;
- end End_Of_File;
-
- function Name (File : in Unbounded_String_Stream)
- return Unbounded_String is
- begin
- return To_Unbounded_String("stdin");
- end Name;
-
- function Line (File : in Unbounded_String_Stream) return Natural is
- begin
- return File.Line_Number;
- end Line;
-
-end Input;
R src/input.ads => +0 -101
@@ 1,101 0,0 @@
---
--- Copyright (c) 2007 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-
-with Ada.Strings.Unbounded;
-with Ada.Sequential_IO;
-with Charbuf;
-
-use Ada.Strings.Unbounded;
-
-package Input is
- use Charbuf;
- -- Abstract source code stream
-
- type Source_Stream is abstract tagged limited record
- Line_Number : Positive := 1;
- end record;
-
- procedure Get
- (File : in out Source_Stream; Char : out Character; Status : out Boolean)
- is abstract;
-
- procedure Put (File : in out Source_Stream; Char : in Character)
- is abstract;
-
- function End_Of_File (File : in Source_Stream) return Boolean
- is abstract;
-
- function Name (File : in Source_Stream) return Unbounded_String
- is abstract;
-
- function Line (File : in Source_Stream) return Natural
- is abstract;
-
- -- A stream from file
-
- type File_Stream is new Source_Stream with private;
-
- procedure Open (File : in out File_Stream; Filename : String);
-
- procedure Close (File : in out File_Stream);
-
- procedure Get
- (File : in out File_Stream; Char : out Character; Status : out Boolean);
-
- procedure Put (File : in out File_Stream; Char : in Character);
-
- function End_Of_File (File : in File_Stream) return Boolean;
-
- function Name (File : in File_Stream) return Unbounded_String;
-
- function Line (File : in File_Stream) return Natural;
-
- -- A stream from Unbounded string
-
- type Unbounded_String_Stream is new Source_Stream with private;
-
- procedure Open (Buffer : in out Unbounded_String_Stream;
- Data : Charbuf.Char_Buffer);
-
- procedure Close (Buffer : in out Unbounded_String_Stream);
-
- procedure Get
- (File : in out Unbounded_String_Stream;
- Char : out Character; Status : out Boolean);
-
- procedure Put (File : in out Unbounded_String_Stream; Char : in Character);
-
- function End_Of_File (File : in Unbounded_String_Stream)
- return Boolean;
-
- function Name (File : in Unbounded_String_Stream) return Unbounded_String;
-
- function Line (File : in Unbounded_String_Stream) return Natural;
-
-private
- package File_IO is new Ada.Sequential_IO (Character);
-
- type File_Stream is new Source_Stream with record
- Buffer : Unbounded_String := Null_Unbounded_String;
- Source_File : File_IO.File_Type;
- Filename : Unbounded_String;
- end record;
-
- type Unbounded_String_Stream is new Source_Stream with record
- Buffer : Charbuf.Char_Buffer;
- end record;
-
-end Input;
R src/json-data.adb => +0 -560
@@ 1,560 0,0 @@
---
--- Copyright (c) 2009 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-with Ada.Strings;
-with Ada.Strings.Fixed;
-with System;
-with Ada.Unchecked_Deallocation;
-with Multi_precision_integers.IO;
-
-package body JSON.Data is
- use Ada.Strings.Unbounded;
-
- function Get_Type (Object : JSON_Root_Type) return JSON_Data_Type is
- begin
- return Object.Type_Kind;
- end Get_Type;
-
- function Get_Value (Object : JSON_Root_Type) return Boolean is
- begin
- raise JSON_Type_Error;
-
- return False;
- end Get_Value;
-
- function Get_Value (Object : JSON_Root_Type) return String is
- begin
- raise JSON_Type_Error;
-
- return "";
- end Get_Value;
-
- function Get_Value (Object : JSON_Root_Type) return JSON_Integer is
- begin
- raise JSON_Type_Error;
-
- return Multi_precision_integers.Multi (0);
- end Get_Value;
-
- function Get_Value (Object : JSON_Root_Type) return JSON_Float is
- begin
- raise JSON_Type_Error;
-
- return 0.0;
- end Get_Value;
-
- function Get_Value (Object : JSON_Root_Type) return JSON_Root_Type'Class is
- begin
- raise JSON_Type_Error;
-
- return JSON_Null_Type'(Ada.Finalization.Controlled with
- Type_Kind => JSON_NULL);
- end Get_Value;
-
- function Get_Value (Object : JSON_Root_Type;
- Position : Positive) return JSON_Root_Type'Class is
- begin
- raise JSON_Type_Error;
-
- return JSON_Null_Type'(Ada.Finalization.Controlled with
- Type_Kind => JSON_NULL);
- end Get_Value;
-
- function Get_Value (Object : JSON_Root_Type;
- Name : String) return JSON_Root_Type'Class is
- begin
- raise JSON_Type_Error;
-
- return JSON_Null_Type'(Ada.Finalization.Controlled with
- Type_Kind => JSON_NULL);
- end Get_Value;
-
- function Length (Object : JSON_Root_Type) return Natural is
- begin
- return 1;
- end Length;
-
- function To_String (Object : JSON_Root_Type) return String is
- begin
- raise JSON_Type_Error;
-
- return "";
- end To_String;
-
- -- Null type
-
- function Create_Null return JSON_Null_Type is
- begin
- return JSON_Null_Type'(Ada.Finalization.Controlled with
- Type_Kind => JSON_NULL);
- end Create_Null;
-
- function Get_Value (Object : JSON_Null_Type) return JSON_Root_Type'Class is
- begin
- return JSON_Null_Type'(Ada.Finalization.Controlled with
- Type_Kind => JSON_NULL);
- end Get_Value;
-
- function To_String (Object : JSON_Null_Type) return String is
- begin
- return "null";
- end To_String;
-
- -- Boolean type
-
- function Create_Boolean (Value : Boolean) return JSON_Boolean_Type is
- O : JSON_Boolean_Type;
- begin
- O.Type_Kind := JSON_BOOLEAN;
- O.Value := Value;
- return O;
- end Create_Boolean;
-
- function Get_Value (Object : JSON_Boolean_Type) return Boolean is
- begin
- return Object.Value;
- end Get_Value;
-
- function To_String (Object : JSON_Boolean_Type) return String is
- begin
- if Object.Value then
- return "true";
- else
- return "false";
- end if;
- end To_String;
-
- -- Number type
-
- function Create_Number (Value : JSON_Integer) return JSON_Number_Type is
- begin
- return (Ada.Finalization.Controlled with
- Type_Kind => JSON_NUMBER,
- Float_Type => False,
- Int_Value => Value,
- Float_Value => 0.0);
- end Create_Number;
-
- function Create_Number (Value : JSON_Float) return JSON_Number_Type is
- begin
- return JSON_Number_Type'(Ada.Finalization.Controlled with
- Type_Kind => JSON_NUMBER,
- Float_Type => True,
- Int_Value => Multi_precision_integers.Multi (0),
- Float_Value => Value);
- end Create_Number;
-
- function Get_Value (Object : JSON_Number_Type) return JSON_Integer is
- begin
- if Object.Float_Type then
- return Multi_precision_integers.Multi
- (Multi_precision_integers.Basic_Int (Object.Float_Value));
- end if;
-
- return Object.Int_Value;
- end Get_Value;
-
- function Get_Value (Object : JSON_Number_Type) return JSON_Float is
- begin
- if not Object.Float_Type then
- return JSON_Float (Multi_precision_integers.Basic (Object.Int_Value));
- end if;
-
- return Object.Float_Value;
- end Get_Value;
-
- function Is_Float (Object : JSON_Number_Type) return Boolean is
- begin
- return Object.Float_Type;
- end Is_Float;
-
- function To_String (Object : JSON_Number_Type) return String is
- begin
- if not Object.Float_Type then
- return Multi_precision_integers.IO.Str (Object.Int_Value);
- else
- return Ada.Strings.Fixed.Trim (JSON_Float'Image
- (Object.Float_Value), Ada.Strings.Both);
- end if;
- end To_String;
-
- -- String type
-
- function Create_String (Value : String) return JSON_String_Type is
- begin
- return JSON_String_Type'(Ada.Finalization.Controlled with
- Type_Kind => JSON_STRING,
- Value => To_Unbounded_String (Value));
- end Create_String;
-
- function Get_Value (Object : JSON_String_Type) return String is
- begin
- return To_String (Object.Value);
- end Get_Value;
-
- function To_String (Object : JSON_String_Type) return String is
- begin
- return '"' & To_String (Object.Value) & '"';
- end To_String;
-
- -- Object Type
-
- function Create_Object return JSON_Object_Type is
- begin
- return
- JSON_Object_Type'(Ada.Finalization.Controlled with
- Type_Kind => JSON_OBJECT,
- Container => Member_List.Empty_List);
- end Create_Object;
-
- function Create_Object (Name : String;
- Child : JSON_Root_Type'Class)
- return JSON_Object_Type is
- Object_List : Member_List.List := Member_List.Empty_List;
- begin
- Member_List.Append (Object_List,
- Pair'(Name => To_Unbounded_String (Name),
- Value => JSON_Holder.To_Holder (Child)));
-
- return
- JSON_Object_Type'(Ada.Finalization.Controlled with
- Type_Kind => JSON_OBJECT,
- Container => Object_List);
- end Create_Object;
-
- procedure Append (Object : in out JSON_Object_Type;
- Name : String;
- Child : JSON_Root_Type'Class) is
- begin
- Member_List.Append (Container => Object.Container,
- New_Item =>
- Pair'(Name => To_Unbounded_String (Name),
- Value => JSON_Holder.To_Holder (Child)));
- end Append;
-
- function Get_Value (Object : JSON_Object_Type;
- Name : String) return JSON_Root_Type'Class is
- use Member_List;
-
- Pos : Cursor := First (Object.Container);
- begin
- loop
- exit when Pos = No_Element;
- if Element (Pos).Name = Name then
- return JSON_Holder.Element (Element (Pos).Value);
- end if;
- Next (Pos);
- end loop;
-
- return JSON_Null_Type'(Ada.Finalization.Controlled with
- Type_Kind => JSON_NULL);
- end Get_Value;
-
- function Get_First (Object : JSON_Object_Type)
- return Member_List.Cursor is
- begin
- return Member_List.First (Object.Container);
- end Get_First;
-
- function Length (Object : JSON_Object_Type) return Natural is
- begin
- return Natural (Member_List.Length (Object.Container));
- end Length;
-
- function To_String (Object : JSON_Object_Type) return String is
- use Member_List;
-
- Pos : Cursor := First (Object.Container);
- Result : Unbounded_String := Null_Unbounded_String;
- begin
- Append (Result, '{');
- loop
- exit when Pos = No_Element;
- Append (Result, '"' & To_String (Element (Pos).Name) & """:");
- Append (Result, To_String (JSON_Holder.Element (Element (Pos).Value)));
- Next (Pos);
- if Pos /= No_Element then
- Append (Result, ',');
- end if;
- end loop;
-
- Append (Result, '}');
- return To_String (Result);
- end To_String;
-
- -- Array type
-
- function Create_Array return JSON_Array_Type is
- A : JSON_Array_Type;
- begin
- A.Type_Kind := JSON_ARRAY;
- A.Container := JSON_Vector.Empty_Vector;
- return A;
- end Create_Array;
-
- procedure Append (Object : in out JSON_Array_Type;
- New_Item : JSon_Root_Type'Class) is
- begin
- JSON_Vector.Append (Object.Container, New_Item);
- end Append;
-
- function Get_Value (Object: JSON_Array_Type;
- Position : Positive) return JSON_Root_Type'Class is
- begin
- return JSON_Vector.Element (Object.Container, Position);
- end Get_Value;
-
- function Length (Object : JSON_Array_Type) return Natural is
- begin
- return Natural (JSON_Vector.Length (Object.Container));
- end Length;
-
- function To_String (Object : JSON_Array_Type) return String is
- use JSON_Vector;
-
- Result : Unbounded_String := Null_Unbounded_String;
- begin
- if Length (Object.Container) = 0 then
- return "[ ]";
- end if;
-
- Append (Result, '[');
- for Place in Count_Type range
- 1 .. Length (Object.Container) loop
- Append (Result, To_String
- (Element (Object.Container, Positive (Place))));
- if Place < Length (Object.Container) then
- Append (Result, ',');
- end if;
- end loop;
- Append (Result, ']');
-
- return To_String (Result);
- end To_String;
-
- package body JSON_Holder is
- procedure Free_Holder is
- new Ada.Unchecked_Deallocation (JSON_Root_Type'Class, JSON_Root_Access);
-
- function "=" (Left, Right : Holder) return Boolean is
- begin
- return Left.Object.all = Right.Object.all;
- end "=";
-
- function To_Holder (New_Item : JSON_Root_Type'Class) return Holder is
- H : Holder;
- begin
- H.Object := new JSON_Root_Type'Class'(New_Item);
- return H;
- end To_Holder;
-
- function To_Holder (New_Item : JSON_Root_Access) return Holder is
- H : Holder;
- begin
- H.Object := New_Item;
- return H;
- end To_Holder;
-
- function Is_Empty (Container : Holder) return Boolean is
- begin
- return Container.Object = null;
- end Is_Empty;
-
- procedure Clear (Container : in out Holder) is
- begin
- Free_Holder (Container.Object);
- Container.Object := null;
- end Clear;
-
- function Element (Container : Holder) return JSON_Root_Type'Class is
- begin
- if Container.Object = null then
- raise Constraint_Error;
- end if;
-
- return Container.Object.all;
- end Element;
-
- procedure Replace_Element (Container : in out Holder;
- New_Item : in JSON_Root_Type'Class) is
- begin
- Free_Holder (Container.Object);
- Container.Object := new JSON_Root_Type'Class'(New_Item);
- end Replace_Element;
-
- procedure Query_Element (Container : in Holder;
- Process : Query_Proc) is
- begin
- if Container.Object = null then
- raise Constraint_Error;
- end if;
-
- Process.all (Container.Object.all);
- end Query_Element;
-
- procedure Update_Element (Container : in Holder;
- Process : Update_Proc) is
- begin
- if Container.Object = null then
- raise Constraint_Error;
- end if;
-
- Process.all (Container.Object.all);
- end Update_Element;
-
- procedure Move (Target : in out Holder; Source : in out Holder) is
- use type System.Address;
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- Clear (Target);
- Target.Object := Source.Object;
- Source.Object := null;
- end Move;
-
- procedure Initialize (Container : in out Holder) is
- begin
- Container.Object := null;
- end Initialize;
-
- procedure Adjust (Container : in out Holder) is
- Item : JSON_Root_Access;
- begin
- if Container.Object /= null then
- Item :=
- new JSON_Root_Type'Class'(Container.Object.all);
- Container.Object := Item;
- end if;
- end Adjust;
-
- procedure Finalize (Container : in out Holder) is
- begin
- Clear (Container);
- end Finalize;
- end JSON_Holder;
-
- package body JSON_Vector is
- procedure Free is
- new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
- procedure Free_Element is
- new Ada.Unchecked_Deallocation (JSON_Root_Type'Class, JSON_Root_Access);
-
- function Capacity (Container : Vector) return Count_Type is
- begin
- if Container.Elements = null then
- return 0;
- end if;
-
- return Count_Type
- (Container.Elements.all'Last - Container.Elements.all'First + 1);
- end Capacity;
-
- procedure Increase_Capacity (Container : in out Vector;
- Addition : Count_Type) is
- Data_New : Element_Array_Access := null;
- Siz : constant Positive'Base := Positive'Base (Container.Size);
- New_Capacity : constant Positive'Base :=
- Positive'Base (Capacity (Container) + Addition);
- begin
- Data_New := new Element_Array
- (Positive'First .. Positive'First + New_Capacity);
- if Container.Elements /= null then
- Data_New.all (Positive'First .. Positive'First + Siz - 1) :=
- Container.Elements.all
- (Container.Elements.all'First ..
- Container.Elements.all'First + Siz - 1);
- Free (Container.Elements);
- end if;
- Container.Elements := Data_New;
- end Increase_Capacity;
-
- procedure Append (Container : in out Vector;
- New_Item : JSON_Root_Type'Class) is
- begin
- if Capacity (Container) <= Length (Container) then
- Increase_Capacity (Container, 10);
- end if;
-
- Container.Elements.all (Container.Elements.all'First +
- Positive'Base (Container.Size)) :=
- new JSON_Root_Type'Class'(New_Item);
- Container.Size := Container.Size + 1;
- end Append;
-
- function Length (Container : Vector) return Count_Type is
- begin
- return Container.Size;
- end Length;
-
- function Element (Container : Vector; Position : Positive)
- return JSON_Root_Type'Class is
- begin
- If Position >= Positive'First + Positive (Container.Size) then
- raise Constraint_Error;
- end if;
-
- return Container.Elements.all (Position).all;
- end Element;
-
- procedure Clear (Container : in out Vector) is
- Index : Positive := Positive'First;
- begin
- loop
- exit when Index >= Positive'First +
- Positive'Base (Container.Size);
- Free_Element (Container.Elements (Index));
- Index := Index + 1;
- end loop;
- Free (Container.Elements);
- Container.Elements := null;
- Container.Size := 0;
- end Clear;
-
- procedure Initialize (Container : in out Vector) is
- begin
- Container.Elements := null;
- Container.Size := 0;
- end Initialize;
-
- procedure Adjust (Container : in out Vector) is
- New_Array : Element_Array_Access;
- begin
- if Container.Elements = null then
- return;
- end if;
-
- New_Array := new Element_Array (Container.Elements.all'Range);
- for I in Container.Elements.all'Range loop
- if Container.Elements (I) /= null then
- declare
- New_Item : JSON_Root_Access;
- begin
- New_Item := new JSON_Root_Type'Class'(Container.Elements (I).all);
- New_Array (I) := New_Item;
- end;
- end if;
- end loop;
- Container.Elements := New_Array;
- end Adjust;
-
- procedure Finalize (Container : in out Vector) is
- begin
- Clear (Container);
- end Finalize;
-
- end JSON_Vector;
-end JSON.Data;
R src/json-data.ads => +0 -296
@@ 1,296 0,0 @@
---
--- Copyright (c) 2009 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-with Ada.Finalization;
-with Ada.Strings.Unbounded;
-
-with Hauki.Containers.Doubly_Linked_Lists;
-
-pragma Elaborate_All (Hauki.Containers.Doubly_Linked_Lists);
-
-package JSON.Data is
-
- type JSON_Data_Type is
- (JSON_NULL,
- JSON_BOOLEAN,
- JSON_NUMBER,
- JSON_STRING,
- JSON_OBJECT,
- JSON_ARRAY);
-
- JSON_Type_Error : exception;
-
- type JSON_Root_Type is abstract new Ada.Finalization.Controlled
- with private;
-
- type JSON_Root_Access is access all JSON_Root_Type'Class;
-
- function Get_Type (Object : JSON_Root_Type) return JSON_Data_Type;
-
- function Get_Value (Object : JSON_Root_Type) return Boolean;
- -- Implemented in:
- -- JSON_Boolean_Type
-
- function Get_Value (Object : JSON_Root_Type) return String;
- -- Implemented in:
- -- JSON_String_Type
-
- function Get_Value (Object : JSON_Root_Type) return JSON_Integer;
- -- Implemented in:
- -- JSON_Number_Type
-
- function Get_Value (Object : JSON_Root_Type) return JSON_Float;
- -- Implemented in:
- -- JSON_Number_Type
-
- function Get_Value (Object : JSON_Root_Type) return JSON_Root_Type'Class;
- -- Implemented in:
- -- JSON_Null_Type
-
- function Get_Value (Object : JSON_Root_Type;
- Position : Positive) return JSON_Root_Type'Class;
- -- Implemented in:
- -- JSON_Array_Type
-
- function Get_Value (Object : JSON_Root_Type;
- Name : String) return JSON_Root_Type'Class;
- -- Implemented in:
- -- JSON_Object_Type
-
- function Length (Object : JSON_Root_Type) return Natural;
-
- function To_String (Object : JSON_Root_Type) return String;
-
- package JSON_Holder is
- type Holder is tagged private;
-
- Empty_Holder : constant Holder;
-
- function "=" (Left, Right : Holder) return Boolean;
-
- function To_Holder (New_Item : JSON_Root_Type'Class) return Holder;
-
- function To_Holder (New_Item : JSON_Root_Access) return Holder;
-
- function Is_Empty (Container : Holder) return Boolean;
-
- procedure Clear (Container : in out Holder);
-
- function Element (Container : Holder) return JSON_Root_Type'Class;
-
- procedure Replace_Element (Container : in out Holder;
- New_Item : in JSON_Root_Type'Class);
-
- type Query_Proc is access procedure (Element : in JSON_Root_Type'Class);
-
- procedure Query_Element (Container : in Holder;
- Process : Query_Proc);
-
- type Update_Proc is access procedure
- (Element : in out JSON_Root_Type'Class);
-
- procedure Update_Element (Container : in Holder;
- Process : Update_Proc);
-
- procedure Move (Target : in out Holder; Source : in out Holder);
-
- private
- -- type Element_Access is access all JSON_Root_Type'Class;
-
- type Holder is new Ada.Finalization.Controlled with record
- Object : JSON_Root_Access;
- end record;
-
- procedure Initialize (Container : in out Holder);
-
- procedure Adjust (Container : in out Holder);
-
- procedure Finalize (Container : in out Holder);
-
- Empty_Holder : constant Holder :=
- (Ada.Finalization.Controlled with Object => null);
-
- end JSON_Holder;
-
- -- Null type
-
- type JSON_Null_Type is new JSON_Root_Type with private;
-
- function Create_Null return JSON_Null_Type;
-
- function Get_Value (Object : JSON_Null_Type) return JSON_Root_Type'Class;
- -- Returns JSON_Null_Type.
-
- function To_String (Object : JSON_Null_Type) return String;
-
- -- Boolean type
-
- type JSON_Boolean_Type is new JSON_Root_Type with private;
-
- function Create_Boolean (Value : Boolean) return JSON_Boolean_Type;
-
- function Get_Value (Object : JSON_Boolean_Type) return Boolean;
- -- Returns True or False
-
- function To_String (Object : JSON_Boolean_Type) return String;
-
- -- Number type
-
- type JSON_Number_Type is new JSON_Root_Type with private;
-
- function Create_Number (Value : JSON_Integer) return JSON_Number_Type;
-
- function Create_Number (Value : JSON_Float) return JSON_Number_Type;
-
- function Get_Value (Object : JSON_Number_Type) return JSON_Integer;
-
- function Get_Value (Object : JSON_Number_Type) return JSON_Float;
-
- function Is_Float (Object : JSON_Number_Type) return Boolean;
-
- function To_String (Object : JSON_Number_Type) return String;
-
- -- String type
-
- type JSON_String_Type is new JSON_Root_Type with private;
-
- function Create_String (Value : String) return JSON_String_Type;
-
- function Get_Value (Object : JSON_String_Type) return String;
-
- function To_String (Object : JSON_String_Type) return String;
-
- -- string:value pair
-
- type Pair is record
- Name : Ada.Strings.Unbounded.Unbounded_String :=
- Ada.Strings.Unbounded.Null_Unbounded_String;
- Value : JSON_Holder.Holder;
- end record;
-
- package Member_List is
- new Hauki.Containers.Doubly_Linked_Lists (Element_Type => Pair);
-
- -- Object Type
-
- type JSON_Object_Type is new JSON_Root_Type with private;
-
- function Create_Object return JSON_Object_Type;
-
- function Create_Object (Name : String;
- Child : JSON_Root_Type'Class)
- return JSON_Object_Type;
- procedure Append (Object : in out JSON_Object_Type;
- Name : String;
- Child : JSON_Root_Type'Class);
-
- function Get_Value (Object : JSON_Object_Type;
- Name : String) return JSON_Root_Type'Class;
-
- function Get_First (Object : JSON_Object_Type)
- return Member_List.Cursor;
-
- function Length (Object : JSON_Object_Type) return Natural;
-
- function To_String (Object : JSON_Object_Type) return String;
-
- -- Array type
-
- type JSON_Array_Type is new JSON_Root_Type with private;
-
- function Create_Array return JSON_Array_Type;
-
- procedure Append (Object : in out JSON_Array_Type;
- New_Item : JSon_Root_Type'Class);
-
- function Get_Value (Object: JSON_Array_Type;
- Position : Positive) return JSON_Root_Type'Class;
-
- function Length (Object : JSON_Array_Type) return Natural;
-
- function To_String (Object : JSON_Array_Type) return String;
-
-private
- type JSON_Root_Type is abstract new Ada.Finalization.Controlled
- with record
- Type_Kind : JSON_Data_Type;
- end record;
-
- type JSON_Null_Type is new JSON_Root_Type with null record;
-
- type JSON_Boolean_Type is new JSON_Root_Type with record
- Value : Boolean;
- end record;
-
- type JSON_Number_Type is new JSON_Root_Type with record
- Float_Type : Boolean;
- Float_Value : JSON_Float;
- Int_Value : JSON_Integer (20);
- end record;
-
- type JSON_String_Type is new JSON_Root_Type with record
- Value : Ada.Strings.Unbounded.Unbounded_String;
- end record;
-
- type JSON_Object_Type is new JSON_Root_Type with record
- Container : Member_List.List;
- end record;
-
- --package JSON_Vector is
- -- new JSON.Indefinite_Vectors (Index_Type => Positive,
- -- Element_Type => JSON_Root_Type'Class);
-
- package JSON_Vector is
-
- type Vector is tagged private;
-
- type Count_Type is new Natural;
-
- Empty_Vector : constant Vector;
-
- procedure Append (Container : in out Vector;
- New_Item : JSON_Root_Type'Class);
-
- function Length (Container : Vector) return Count_Type;
-
- function Element (Container : Vector; Position : Positive)
- return JSON_Root_Type'Class;
-
- procedure Clear (Container : in out Vector);
-
- private
- type Element_Array is
- array (Positive range <>) of JSON_Root_Access;
-
- type Element_Array_Access is access all Element_Array;
-
- type Vector is new Ada.Finalization.Controlled with record
- Elements : Element_Array_Access;
- Size : Count_Type;
- end record;
-
- procedure Initialize (Container : in out Vector);
- procedure Adjust (Container : in out Vector);
- procedure Finalize (Container : in out Vector);
-
- Empty_Vector : constant Vector := (Ada.Finalization.Controlled with
- Elements => null,
- Size => 0);
- end JSON_Vector;
-
- type JSON_Array_Type is new JSON_Root_Type with record
- Container : JSON_Vector.Vector;
- end record;
-end JSON.Data;
R src/json-lexer.adb => +0 -393
@@ 1,393 0,0 @@
---
--- Copyright (c) 2009 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-with Ada.Characters.Latin_1;
-with Ada.Characters.Handling;
-with Multi_precision_integers.IO; use Multi_precision_integers.IO;
-with Ada.Text_IO; use Ada.Text_IO;
-
-package body JSON.Lexer is
- function Is_White_Space (C : Character) return Boolean
- is
- White_Space : constant array(Positive range <>) of Character :=
- (' ',
- Ada.Characters.Latin_1.HT,
- Ada.Characters.Latin_1.LF,
- Ada.Characters.Latin_1.CR);
- begin
- for I in White_Space'First .. White_Space'Last loop
- if C = White_Space (I) then
- return True;
- end if;
- end loop;
- return False;
- end Is_White_Space;
-
- function Is_JSON_Letter (C : Character) return Boolean is
- begin
- return Ada.Characters.Handling.Is_Letter (C);
- end Is_JSON_Letter;
-
- function Is_JSON_Digit (C : Character) return Boolean is
- begin
- return Ada.Characters.Handling.Is_Digit (C);
- end Is_JSON_Digit;
-
- procedure Skip_Comment (Source : in out Source_Stream'Class) is
- Ch : Character;
- Status : Boolean;
- Prev : Character := Character'Val(0);
- begin
- loop
- Get (Source, Ch, Status);
- exit when (Status = False) or (Prev = '*' and Ch = '/');
- Prev := Ch;
- end loop;
- end Skip_Comment;
-
- -- Skips whitespace characters and comments
- procedure Skip_Space (Source : in out Source_Stream'Class) is
- Ch : Character;
- Status : Boolean;
- Prev : Character := Character'Val(0);
- begin
- -- Put_Line("Skip_Space");
- loop
- Get (Source, Ch, Status);
- exit when not Status;
- if (Prev = '/') and (Ch = '*') then -- comment begins
- Skip_Comment (Source);
- -- After skipping comment, previous char should
- -- be the comment ending mark (or eof)
- Prev := '/';
- elsif (Prev = '/') and (Ch /= '*') then -- not a comment
- Put (Source, Ch);
- Put (Source, Prev);
- exit;
-
- -- We can exit, because the character is something else than '('
- -- or a whitespace
- elsif (Ch /= '/') and (not Is_White_Space (Ch)) then
- if (Prev /= Character'Val(0)) and (not Is_White_Space (Prev)) then
- Put (Source, Prev);
- end if;
- Put (Source, Ch);
- exit;
- else
- Prev := Ch;
- end if;
- end loop;
- end Skip_Space;
-
- function Zero_Val return JSON_Integer is
- X : JSON_Integer (20);
- begin
- Multi_precision_integers.Fill (X, 0);
-
- return X;
- end Zero_Val;
-
- procedure Parse_Keyword (Source : in out Source_Stream'Class;
- T : out Token_Type) is
- Ch : Character;
- Status : Boolean;
- Buffer : Unbounded_String;
- begin
- -- Put_Line("Parse_Keyword");
- loop
- Get (Source, Ch, Status);
-
- if Status = False then
- Put_Line ("Invalid token, Status = False (Parse_Keyword)");
- T.Token_Kind := INVALID_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- exit;
- elsif not Is_JSON_Letter (Ch) then
- Put (Source, Ch);
- if Buffer = "true" then
- T.Token_Kind := TRUE_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- elsif Buffer = "false" then
- T.Token_Kind := FALSE_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- elsif Buffer = "null" then
- T.Token_Kind := NULL_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- else
- Put_Line ("Invalid token, not a JSON letter (Parse_Keyword): " & Ch);
- T.Token_Kind := INVALID_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- end if;
- exit;
- else
- Append (Buffer, Ch);
- end if;
- end loop;
- end Parse_Keyword;
-
- procedure Parse_String (Source : in out Source_Stream'Class;
- T : out Token_Type) is
- type State_Enum is (NORMAL, ESCAPED_START, ESCAPED_UNICODE);
-
- Ch : Character;
- Status : Boolean;
- Buffer : Unbounded_String;
- Uni_Buffer : Unbounded_String;
- State : State_Enum := NORMAL;
- begin
- -- Put_Line("Parse_String");
- loop
- Get (Source, Ch, Status);
-
- if Status = False then
- Put_Line ("Parse_String: End of data");
- T.Token_Kind := INVALID_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- exit;
- elsif Ch = '"' and State = NORMAL then
- T.Token_Kind := STRING_TOKEN;
- T.String_Value := Buffer;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- exit;
- elsif Ch = '\' and State = NORMAL then
- State := ESCAPED_START;
- elsif State = ESCAPED_START then
- case Ch is
- when '"' =>
- Append (Buffer, Ch);
- when '\' =>
- Append (Buffer, Ch);
- when '/' =>
- Append (Buffer, Ch);
- when 'b' =>
- null; -- TODO
- when 'f' =>
- null; -- TODO
- when 'n' =>
- null; -- TODO
- when 'r' =>
- null; -- TODO
- when 't' =>
- null; -- TODO
- when ' ' =>
- Append (Buffer, Ch);
- when 'u' =>
- State := ESCAPED_UNICODE;
- Uni_Buffer := Null_Unbounded_String;
- when others =>
- Put_Line ("Parse_String: Got character: " & Ch & " "
- & Integer'Image(Character'Pos(Ch)));
- T.Token_Kind := INVALID_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- exit;
- end case;
- if State = ESCAPED_START then
- State := NORMAL;
- end if;
- elsif State = ESCAPED_UNICODE then
- null; -- TODO
- Append (Uni_Buffer, Ch);
- if Length (Uni_Buffer) > 3 then
- State := NORMAL;
- end if;
- else
- Append (Buffer, Ch);
- end if;
- end loop;
- end Parse_String;
-
- -- For now we support only normal base 10 numbers.
- -- TODO Add hex number support.
- procedure Parse_Number (Source : in out Source_Stream'Class;
- T : out Token_Type) is
- Ch : Character;
- Source_Status : Boolean;
- Buffer : Unbounded_String := Null_Unbounded_String;
- Dot_Found : Boolean := False;
- begin
- -- Put_Line("Parse_Number");
- Skip_Space (Source);
- Get (Source, Ch, Source_Status);
- if Source_Status = False then
- Put_Line ("Parse_Number: Invalid token, status = False");
- T.Token_Kind := INVALID_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- return;
- end if;
- if Is_JSON_Digit (Ch) or Ch = '-' or Ch = '+' then
- Append (Buffer, Ch);
- else
- Put_Line ("Parse_Number: Invalid token, not a digit " & Ch);
- T.Token_Kind := INVALID_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- Put (Source, Ch);
- return;
- end if;
- loop
- Get (Source, Ch, Source_Status);
- exit when Source_Status = False;
-
- if Is_JSON_Digit (Ch) then
- Append (Buffer, Ch);
- elsif Ch = '.' and Dot_Found = False then
- Append (Buffer, Ch);
- Dot_Found := True;
- elsif Is_JSON_Letter (Ch) then
- Put (Source, Ch);
- Put_Line ("Parse_Number: Invalid token, got a letter");
- T.Token_Kind := INVALID_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- return;
- else
- Put (Source, Ch);
- exit;
- end if;
- end loop;
-
- if Dot_Found = False then
- begin
- declare
- V : JSON_Integer := Val (To_String (Buffer));
- begin
- T.Token_Kind := INTEGER_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Float_Value := 0.0;
- Multi_precision_integers.Fill (T.Integer_Value, V);
- end;
- exception
- when Constraint_Error =>
- Put_Line ("Parse_Number: Invalid_Token, Constraint_Error (integer)");
- T.Token_Kind := INVALID_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- -- T := Token_Type'
- -- (Token_Kind => INTEGER_TOKEN,
- -- Integer_Value => Multi_precision_integers.Multi (0));
- raise;
- end;
- else
- begin
- T.Token_Kind := FLOAT_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := Float'Value (To_String (Buffer));
- exception
- when Constraint_Error =>
- Put_Line ("Parse_Number: Invalid_Token, Constraint_Error (float)");
- T.Token_Kind := INVALID_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- return;
- end;
- end if;
- end Parse_Number;
-
- procedure Parse_Token (Source : in out Source_Stream'Class;
- T : out Token_Type) is
- Ch : Character;
- Status : Boolean;
- -- Buffer : Unbounded_String := Null_Unbounded_String;
- begin
- -- Put_Line("Parse_Token");
- Skip_Space (Source);
-
- Get (Source, Ch, Status);
- if not Status then
- T.Token_Kind := EOF_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- return;
- end if;
-
- case Ch is
- when ',' =>
- T.Token_Kind := COMMA_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- when ':' =>
- T.Token_Kind := COLON_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- when '[' =>
- T.Token_Kind := BOX_PARENT_LEFT_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- when ']' =>
- T.Token_Kind := BOX_PARENT_RIGHT_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- when '"' =>
- Parse_String (Source, T);
- when '{' =>
- T.Token_Kind := CURLY_PARENT_LEFT_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- when '}' =>
- T.Token_Kind := CURLY_PARENT_RIGHT_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- when '1'|'2'|'3'|'4'|'5'|'6'|'7'|'8'|'9'|'0'|'+'|'-' =>
- Put (Source, Ch);
- Parse_Number (Source, T);
- when 't'|'f'|'n' =>
- Put (Source, Ch);
- Parse_Keyword (Source, T);
- when '\' =>
- Put_Line ("Parse_Token: Invalid_Token, Ch = \");
- T.Token_Kind := INVALID_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- -- TODO
- when others =>
- Put_Line ("Parse_Token: Invalid_Token, Ch: " & Ch);
- T.Token_Kind := INVALID_TOKEN;
- T.String_Value := Null_Unbounded_String;
- T.Integer_Value := Zero_Val;
- T.Float_Value := 0.0;
- end case;
-
- end Parse_Token;
-end JSON.Lexer;
R src/json-lexer.ads => +0 -50
@@ 1,50 0,0 @@
---
--- Copyright (c) 2009 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-with Ada.Strings.Unbounded;
-with Input;
-
-package JSON.Lexer is
- use Ada.Strings.Unbounded;
- use Input;
-
- type Token_Enum is
- (
- INVALID_TOKEN,
- COMMA_TOKEN, -- ,
- COLON_TOKEN, -- :
- BOX_PARENT_LEFT_TOKEN, -- [
- BOX_PARENT_RIGHT_TOKEN, -- ]
- CURLY_PARENT_LEFT_TOKEN, -- {
- CURLY_PARENT_RIGHT_TOKEN, -- }
- STRING_TOKEN, -- "abc"
- INTEGER_TOKEN, -- 1234
- FLOAT_TOKEN, -- 12.34
- TRUE_TOKEN, -- true
- FALSE_TOKEN, -- false
- NULL_TOKEN, -- null
- EOF_TOKEN
- );
-
- type Token_Type is record
- Token_Kind : Token_Enum := INVALID_TOKEN;
- String_Value : Unbounded_String := Null_Unbounded_String;
- Integer_Value : JSON_Integer (20);
- Float_Value : JSON_Float := 0.0;
- end record;
-
- procedure Parse_Token (Source : in out Source_Stream'Class;
- T : out Token_Type);
-end JSON.Lexer;
R src/json-parser.adb => +0 -170
@@ 1,170 0,0 @@
---
--- Copyright (c) 2009 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-with Ada.Text_IO; use Ada.Text_IO;
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-
-with JSON.Lexer;
-
-package body JSON.Parser is
- use JSON.Lexer;
- procedure Parse_Array (Source : in out Source_Stream'Class;
- T : in out Token_Type;
- Value : out JSON.Data.JSON_Holder.Holder);
-
- procedure Parse_Value (Source : in out Source_Stream'Class;
- T : in out Token_Type;
- Value : out JSON.Data.JSON_Holder.Holder);
-
- procedure Parse_Pair (Source : in out Source_Stream'Class;
- T : in out Token_Type;
- Value : out JSON.Data.JSON_Holder.Holder);
-
- procedure Parse_Object (Source : in out Source_Stream'Class;
- T : in out Token_Type;
- Value : out JSON.Data.JSON_Holder.Holder);
-
- procedure Parse_Array (Source : in out Source_Stream'Class;
- T : in out Token_Type;
- Value : out JSON.Data.JSON_Holder.Holder) is
- use JSON.Data.JSON_Holder;
-
- Item : Holder;
- Temp_Array : Data.JSON_Array_Type := Data.Create_Array;
- begin
- Put_Line("Parse_Array");
- Parse_Token (Source, T);
- case T.Token_Kind is
- when BOX_PARENT_RIGHT_TOKEN =>
- null;
- when others =>
- Clear (Item);
- loop
- Parse_Value (Source, T, Item);
- Data.Append (Temp_Array, Element (Item));
- Parse_Token (Source, T);
- if T.Token_Kind = BOX_PARENT_RIGHT_TOKEN then
- exit;
- elsif T.Token_Kind /= COMMA_TOKEN then
- raise Parse_Error;
- end if;
- Parse_Token (Source, T);
- end loop;
- end case;
- Value := To_Holder (Temp_Array);
- end Parse_Array;
-
- -- value = string | number | object | array | true | false | null
- procedure Parse_Value (Source : in out Source_Stream'Class;
- T : in out Token_Type;
- Value : out JSON.Data.JSON_Holder.Holder) is
- use JSON.Data.JSON_Holder;
- begin
- case T.Token_Kind is
- when STRING_TOKEN =>
- Value := To_Holder
- (JSON.Data.Create_String (To_String (T.String_Value)));
- when INTEGER_TOKEN =>
- Value := To_Holder (JSON.Data.Create_Number (T.Integer_Value));
- when FLOAT_TOKEN =>
- Value := To_Holder (JSON.Data.Create_Number (T.Float_Value));
- when TRUE_TOKEN =>
- Value := To_Holder (JSON.Data.Create_Boolean (True));
- when FALSE_TOKEN =>
- Value := To_Holder (JSON.Data.Create_Boolean (False));
- when NULL_TOKEN =>
- Value := To_Holder (JSON.Data.Create_Null);
- when CURLY_PARENT_LEFT_TOKEN =>
- Parse_Object (Source, T, Value);
- when BOX_PARENT_LEFT_TOKEN =>
- Parse_Array (Source, T, Value);
- when others =>
- Put_Line ("Got token: " & Token_Enum'Image (T.Token_Kind));
- Put_Line ("Line: " & Natural'Image (Input.Line (Source)));
- raise Parse_Error;
- end case;
- end Parse_Value;
-
- -- pair = string : value
- procedure Parse_Pair (Source : in out Source_Stream'Class;
- T : in out Token_Type;
- Value : out JSON.Data.JSON_Holder.Holder) is
- begin
- Parse_Token (Source, T);
- if T.Token_Kind /= COLON_TOKEN then
- raise Parse_Error;
- end if;
- Parse_Token (Source, T);
- Parse_Value (Source, T, Value);
- end Parse_Pair;
-
- procedure Parse_Object (Source : in out Source_Stream'Class;
- T : in out Token_Type;
- Value : out JSON.Data.JSON_Holder.Holder) is
- use JSON.Data.JSON_Holder;
-
- Item : Holder;
- Object : Data.JSON_Object_Type := Data.Create_Object;
- begin
- Put_Line("Parse_Object");
- if T.Token_Kind /= CURLY_PARENT_LEFT_TOKEN then
- raise Parse_Error;
- end if;
-
- Member_Loop:
- loop
- Parse_Token (Source, T);
-
- case T.Token_Kind is
- when CURLY_PARENT_RIGHT_TOKEN =>
- exit Member_Loop;
- when STRING_TOKEN =>
- declare
- Name : constant String := To_String (T.String_Value);
- begin
- Parse_Pair (Source, T, Item);
- Data.Append (Object, Name, Element (Item));
- end;
- Parse_Token (Source, T);
- if T.Token_Kind = CURLY_PARENT_RIGHT_TOKEN then
- exit Member_Loop;
- elsif T.Token_Kind /= COMMA_TOKEN then
- raise Parse_Error;
- end if;
- when others =>
- raise Parse_Error;
- end case;
- end loop Member_Loop;
- Value := To_Holder (Object);
- end Parse_Object;
-
- procedure Parse (Source : in out Source_Stream'Class;
- Object : out JSON.Data.JSON_Holder.Holder) is
- T : Token_Type;
- begin
- Put_Line("Parse");
- Parse_Token (Source, T);
- case T.Token_Kind is
- when CURLY_PARENT_LEFT_TOKEN =>
- Parse_Object (Source, T, Object);
- when BOX_PARENT_LEFT_TOKEN =>
- Parse_Array (Source, T, Object);
- when others =>
- raise Parse_Error;
- end case;
- end Parse;
-
-end JSON.Parser;
-
R src/json-parser.ads => +0 -27
@@ 1,27 0,0 @@
---
--- Copyright (c) 2009 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-with Input;
-with JSON.Data;
-
-package JSON.Parser is
- use Input;
-
- Parse_Error : exception;
-
- procedure Parse (Source : in out Source_Stream'Class;
- Object : out JSON.Data.JSON_Holder.Holder);
-
-end JSON.Parser;
R src/json.ads => +0 -22
@@ 1,22 0,0 @@
---
--- Copyright (c) 2009 Tero Koskinen <tero.koskinen@iki.fi>
---
--- Permission to use, copy, modify, and distribute this software for any
--- purpose with or without fee is hereby granted, provided that the above
--- copyright notice and this permission notice appear in all copies.
---
--- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
--- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
--- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
--- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
--- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
--- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
--- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---
-
-with Multi_precision_integers;
-
-package JSON is
- subtype JSON_Integer is Multi_precision_integers.Multi_Int;
- subtype JSON_Float is Float;
-end JSON;
R src/multi_precision_integers-check.adb => +0 -141
@@ 1,141 0,0 @@
-with Ada.Text_IO; use Ada.Text_IO;
--- !! will disappear in favour of Ada.Exceptions
-
-with Multi_precision_integers.IO;
-
-package body Multi_precision_integers.Check is
-
- package IOi renames Multi_precision_integers.IO;
-
- -- Don't be afraid by the bug reporting tools,
- -- they are unlikely to pop out of a programme ;-)
-
- Bug_file: Ada.Text_IO.File_type;
- Bug_file_name: constant String:= "mupreint.bug";
-
- -- The flaw detection (DEBUG mode) could suffer from
- -- a chicken-and-egg problem: e.g. "*" works, but the "/"
- -- to verify it doesn't !
-
- Multiply_flawed_div1_has_rest : exception;
- Multiply_flawed_div1_wrong_quotient : exception;
- Multiply_flawed_div2_has_rest : exception;
- Multiply_flawed_div2_wrong_quotient : exception;
-
- Div_Rem_flawed : exception;
-
- procedure Open_Bug_Report is
- begin
- Create( Bug_file, out_file, Bug_file_name );
- Put_Line( Bug_file, "Bug in Multi_precision_integers");
- end Open_Bug_Report;
-
- procedure Close_Bug_Report is
- begin
- Close( Bug_file );
- -- These console messages can provoke a silent quit in GUI apps,
- -- so we put them after closing the report.
- Put_Line( "Bug in Multi_precision_integers !");
- Put_Line( "For details, read file: " & Bug_file_name);
- end Close_Bug_Report;
-
- procedure Test( m: multi_int; test_last: Boolean:= True ) is
- last_nz: index_int:= 0;
- Negative_block,
- Last_index_has_zero,
- Field_last_outside_range, Field_last_is_negative: exception;
- begin
- if m.zero then return; end if; -- 0, nothing to test
- if m.last_used > m.n then raise Field_last_outside_range; end if;
- if m.last_used < 0 then raise Field_last_is_negative; end if;
- for i in 0 .. m.last_used loop
- if m.blk(i) < 0 then
- raise Negative_block;
- end if;
- if m.blk(i) /= 0 then
- last_nz:= i;
- end if;
- end loop;
- if test_last and then 0 < last_nz and then last_nz < m.last_used then
- raise Last_index_has_zero;
- end if;
- end Test;
-
- procedure Check_Multiplication(i1,i2,i3: in multi_int) is
- jeu: constant:= 5; -- 0 suffit
- q1: Multi_int( i2.last_used + jeu );
- r1: Multi_int( i1.last_used + i2.last_used + jeu );
- q2: Multi_int( jeu );
- r2: Multi_int( i2.last_used + jeu );
-
- procedure Bug_Report is
- begin
- Open_Bug_Report;
- Put_Line( Bug_file, "Multiply_and_verify");
- Put( Bug_file, "i1 ="); IOi.Put_in_blocks(Bug_file, i1); New_Line(Bug_file);
- Put( Bug_file, "i2 ="); IOi.Put_in_blocks(Bug_file, i2); New_Line(Bug_file);
- Put( Bug_file, "i3 ="); IOi.Put_in_blocks(Bug_file, i3); New_Line(Bug_file);
- end Bug_Report;
-
- begin
- Test(i1);
- Test(i2);
-
- if not (i1.zero or i2.zero) then
- -- Now we divide i3 by i1, q1 should be = i2
- Div_Rem_internal_both_export(i3,i1, q1,r1);
- if not r1.zero then
- Bug_Report;
- Close_Bug_Report;
- raise Multiply_flawed_div1_has_rest;
- end if;
- if not Equal( q1, i2 ) then
- Bug_Report;
- Put( Bug_file, "q1 ="); IOi.Put_in_blocks(Bug_file, q1); New_Line(Bug_file);
- Close_Bug_Report;
- raise Multiply_flawed_div1_wrong_quotient;
- end if;
- -- Now we divide q1 by i2, should be = 1
- Div_Rem_internal_both_export(q1,i2, q2,r2);
- if not r2.zero then
- Bug_Report;
- Close_Bug_Report;
- raise Multiply_flawed_div2_has_rest;
- end if;
- if not Equal( q2, Multi(1) ) then
- Bug_Report;
- Put( Bug_file, "q2 ="); IOi.Put_in_blocks(Bug_file, q1); New_Line(Bug_file);
- Close_Bug_Report;
- raise Multiply_flawed_div2_wrong_quotient;
- end if;
- end if;
-
- end Check_Multiplication;
-
- procedure Check_Div_Rem(i1,i2,q,r: in multi_int) is
-
- procedure Bug_Report is
- begin
- Open_Bug_Report;
- Put_Line( Bug_file, "Div_Rem_and_verify");
- Put( Bug_file, "i1 ="); IOi.Put_in_blocks(Bug_file, i1); New_Line(Bug_file);
- Put( Bug_file, "i2 ="); IOi.Put_in_blocks(Bug_file, i2); New_Line(Bug_file);
- Put( Bug_file, "q ="); IOi.Put_in_blocks(Bug_file, q); New_Line(Bug_file);
- Put( Bug_file, "r ="); IOi.Put_in_blocks(Bug_file, r); New_Line(Bug_file);
- end Bug_Report;
-
- begin
- Test(i1);
- Test(i2);
-
- if not Equal( i1, i2*q + r ) then
- Bug_Report;
- Close_Bug_Report;
- raise Div_Rem_flawed;
- end if;
-
- Test(q);
- Test(r);
- end Check_Div_Rem;
-
-end Multi_precision_integers.Check;
R src/multi_precision_integers-check.ads => +0 -12
@@ 1,12 0,0 @@
-package Multi_precision_integers.Check is
-
- -- check integrity
- procedure Test( m: multi_int; test_last: Boolean:= True );
-
- -- i3 must be = i1 * i2
- procedure Check_Multiplication(i1,i2,i3: in multi_int);
-
- -- i1 must be = i2 * q + r
- procedure Check_Div_Rem(i1,i2,q,r: in multi_int);
-
-end Multi_precision_integers.Check;
R src/multi_precision_integers-io.adb => +0 -186
@@ 1,186 0,0 @@
------------------------------------------------------------------------------
--- File: muprinio.adb; see specification (muprinio.ads)
------------------------------------------------------------------------------
-
-package body Multi_precision_integers.IO is
-
- package IIO is new Integer_IO( index_int );
-
- table: constant array(basic_int'(0)..15) of Character:=
- ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
-
- -- 15-Feb-2002: Bugfix case i=0. Spotted by Duncan Sands
-
- function Chiffres_i_non_nul(i: multi_int; base: number_base:= 10) return Natural is
- nombre: multi_int(i.last_used);
- la_base : constant basic_int := basic_int(base);
- nchiffres: Natural:= 1;
-
- procedure Comptage_rapide( C: Positive ) is
- test : multi_int(i.n);
- base_puiss_C: constant multi_int:= Multi( basic_int(base) ) ** C;
- begin
- loop
- Fill(test, nombre / base_puiss_C );
- exit when test.zero;
- -- quotient non nul, donc on a au moins C chiffres
- Fill(nombre, test);
- nchiffres:= nchiffres + C;
- end loop;
- end Comptage_rapide;
-
- begin
- Fill(nombre, i);
- Comptage_rapide( 400 );
- Comptage_rapide( 20 );
- loop
- Fill(nombre, nombre / la_base);
- exit when nombre.zero;
- nchiffres:= nchiffres + 1;
- end loop;
- return nchiffres;
- end Chiffres_i_non_nul;
-
- function Number_of_digits(i: multi_int; base: number_base:= 10) return Natural is
- begin
- if i.zero then
- return 1;
- else
- return Chiffres_i_non_nul(i,base);
- end if;
- end Number_of_digits;
-
- function Str(i: multi_int; base: number_base:= 10) return String is
- res: String(1..1 + Number_of_digits(i,base)):= (others=> 'x');
- nombre : multi_int(i.n):= i;
- chiffre: basic_int;
- la_base: constant basic_int := basic_int(base);
-
- begin
- if nombre.zero or else not nombre.neg then
- res(1):= ' ';
- else
- res(1):= '-';
- end if;
- nombre.neg:= False;
-
- -- maintenant nombre et base sont >=0, MOD=REM
- for k in reverse 2 .. res'Last loop
- Div_Rem( nombre, la_base, nombre, chiffre );
- res(k):= table( chiffre );
- exit when nombre.zero;
- end loop;
- return res;
-