-- NILIADA - Lisp objects in Ada -- Copyright (c) 1999--2004 Alexandru Dan Corlan MD PhD (http://dan.corlan.net) -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -- Get the latest version of this program from: -- http://dan.corlan.net/software/niliada.ada -- History: -- 1999 -- first version, symbols, numbers and strings -- [supported by a grant from the ESC (www.escardio.org)] -- 2001 -- added controlled finalization (incremental GC), -- support for bitvectors -- 2001-2003 -- extensive testing -- feb6 2004 -- release 3042 with Ada.Finalization; use Ada.Finalization; with Ada; with Ada.Unchecked_Deallocation; with Direct_Io; with Text_Io; use Text_Io; package Niliada is type Cell_Root is abstract tagged record Linkount: Integer := 1; end record; type Cell_Root_Ptr is access Cell_Root'Class; type Cell is new Ada.Finalization.Controlled with record P: Cell_Root_Ptr := null; end record; procedure Free is new Ada.Unchecked_Deallocation(Cell_Root'Class, Cell_Root_Ptr); procedure Finalize(Object: in out Cell); procedure Adjust(Object: in out Cell); --- INTEGERS --- type Integer_Cell is new Cell_Root with record Val: Long_Long_Integer; end record; function Make_Integer(Int: Long_Long_Integer) return Cell; function Make_Integer(Int: Long_Integer) return Cell; function Make_Integer(Int: Integer) return Cell; function Integerp(C: Cell) return Boolean; -- function Integer_Of(C: Cell) return Integer; -- function Integer_Of(C: Cell) return Long_Integer; function Integer_Of(C: Cell) return Long_Long_Integer; pragma Inline(Integerp, Integer_Of); -- function Integerp(C: Cell) return Cell; --- FLOATS --- type Float_Cell is new Cell_Root with record Val: Long_Long_Float; end record; function Make_Float(Int: Long_Long_Float) return Cell; function Make_Float(Int: Long_Float) return Cell; function Make_Float(Int: Float) return Cell; function Floatp(C: Cell) return Boolean; function Float_Of(C: Cell) return Float; function Float_Of(C: Cell) return Long_Float; function Float_Of(C: Cell) return Long_Long_Float; pragma Inline(Floatp, Float_Of); --- Other number functions --- function Numberp(Cc: Cell) return Boolean; pragma Inline(Numberp); --- LISTS --- type Cons_Cell is new Cell_Root with record Head: Cell; Tail: Cell; end record; function Cons(Car, Cdr: Cell) return Cell; function Car(Cc: Cell) return Cell; function Cdr(Cc: Cell) return Cell; function Consp(Cc: Cell) return Boolean; function Listp(Cc: Cell) return Boolean; function Nullp(Cc: Cell) return Boolean; procedure Rplaca(Where, By: Cell); procedure Rplacd(Where, By: Cell); function Caar(Cc: Cell) return Cell; function Cadr(Cc: Cell) return Cell; function Cdar(Cc: Cell) return Cell; function Cddr(Cc: Cell) return Cell; function Caaar(Cc: Cell) return Cell; function Caadr(Cc: Cell) return Cell; function Cadar(Cc: Cell) return Cell; function Caddr(Cc: Cell) return Cell; function Cdaar(Cc: Cell) return Cell; function Cdadr(Cc: Cell) return Cell; function Cddar(Cc: Cell) return Cell; function Cdddr(Cc: Cell) return Cell; pragma Inline(Car, Cdr, Consp, Listp, Nullp, Rplaca, Rplacd); pragma Inline(Caar, Cadr, Cdar, Cddr, Caaar, Caadr, Cadar, Caddr, Cdaar, Cdadr, Cddar, Cdddr); function Alist_Value(Alist: Cell; Key: String) return String; function Alist_Value(Alist: Cell; Key: String) return Cell; function Alist_Value(Alist, Key: Cell) return String; function Alist_Value(Alist, Key: Cell) return Cell; function Alist_Has_Value(Alist: Cell; Key: String) return Boolean; function Alist_Has_Value(Alist, Key: Cell) return Boolean; function "/" (Alist: Cell; Key: String) return String renames Alist_Value; function "/" (Alist: Cell; Key: String) return Cell renames Alist_Value; function "/" (Alist,Key: Cell) return String renames Alist_Value; function "/" (Alist,Key: Cell) return Cell renames Alist_Value; function "/" (Alist,Key: Cell) return Boolean renames Alist_Has_Value; function "/" (Alist: Cell; Key: String) return Boolean renames Alist_Has_Value; --- other functions --- function Reverse_List(C: Cell) return Cell; function Append_List(A,B: Cell) return Cell; function Member(A,L: Cell) return Boolean; function Union(L,M: Cell) return Cell; function Intersect(L,M: Cell) return Cell; function Difference(L,M: Cell) return Cell; --- STRINGS --- type String_Cell(Len: Integer) is new Cell_Root with record Str: String(1..Len); end record; function Make_String(S: String) return Cell; function String_Of(Cc: Cell) return String; function Stringp(Cc: Cell) return Boolean; pragma Inline(Stringp, String_Of); --- bit-vectors --- type Bit_Vector is array(Integer range <>) of Boolean; pragma Pack(Bit_Vector); type Bit_Vector_Ptr is access all Bit_Vector; type Bit_Vector_Cell(Len: Integer) is new Cell_Root with record Fill: Integer :=0; Bv: aliased Bit_Vector(1..Len) := (others => False); end record; function Make_Bit_Vector(Len: Integer; Fill: Integer:= 0) return Cell; function Bit_Vector_P(Bv: Cell) return Boolean; pragma Inline(Bit_Vector_P); function Elt(Bv: Cell; I: Integer) return Boolean; pragma Inline(Elt); procedure Set(Bv: Cell; I: Integer; Val: Boolean); pragma Inline(Set); procedure Append(Bv: Cell; Val: Boolean); pragma Inline(Append); function Bit_And(Bv1, Bv2: Cell) return Cell; function Bit_Or(Bv1, Bv2: Cell) return Cell; function Bit_Not(Bv: Cell) return Cell; function Bit_Count(Bv: Cell) return Integer; -- iterator implementations available -- ''fast'' versions are actually faster when bitvectors are sparse -- for very sparse vectors can be 30 times faster, but for vectors -- denser than 0.5 can be down to 70% slower than ''slow'' versions -- for bitvectors denser than 0.5 these functions are to 2 times -- slower than calling loops of elt but for very sparse vectors -- (under 1000 in a million) they can be 50--85 times faster -- than loops of elts function Slow_First_Bit(Bv: Cell) return Natural; -- return 0 if no bit set pragma Inline(Slow_First_Bit); function Fast_First_Bit(Bv: Cell) return Natural; pragma Inline(Fast_First_Bit); function Slow_Next_Bit(Bv: Cell; Crt: Natural) return Natural; -- return 0 if no more bits set pragma Inline(Slow_Next_Bit); function Fast_Next_Bit(Bv: Cell; Crt: Natural) return Natural; pragma Inline(Fast_Next_Bit); -- actual iterators to be used by caller function First_Bit(Bv: Cell) return Natural renames Fast_First_Bit; -- pragma(Inline(First_Bit)); function Next_Bit(Bv: Cell; Crt: Natural) return Natural renames Fast_Next_Bit; -- pragma(Inline(Next_Bit)); --- SEQUENCES --- function Length(Cc: Cell) return Integer; --- SYMBOLS AND THE HASH TABLE --- type Symbol_Cell(Len: Integer) is new Cell_Root with record Name: String(1..Len); end record; function Intern(S: String) return Cell; function Symbol_Name(Cc: Cell) return String; function Symbolp(C: Cell) return Boolean; type Hash_Bucket is array(Integer range <>) of Cell; type Hash_Bucket_Ptr is access Hash_Bucket; type Hash_Bucket_Set is array(Integer range <>) of Hash_Bucket_Ptr; type Hashtable_Cell(Len: Integer) is new Cell_Root with record Buckets: Hash_Bucket_Set(1..Len) := (others => null); end record; --- STREAM TYPES --- package Chio is new Direct_Io(Character); type Stream_Types is (Str, File, New_File); type String_Access is access all String; type File_Ptr is access all Chio.File_Type; type File_Mode is (Input, Output, Input_Output, Append, Closed); subtype File_Count is Chio.Count; Default_Buffer_Size: constant Integer := 65_536; type Stream_Cell(Mode: Stream_Types) is new Cell_Root with record Direction: File_Mode:= Closed; Ungetc: Character; Ungetcf: Boolean:= False; case Mode is when Str => Strv: String_Access := null; -- string must be have 1..len as index type Read_Ix: Integer:= 1; Write_Ix: Integer:= 1; Len: Integer:= 0; Tell: Integer:= 0; when File => Const_Filev: File_Access; when New_File => Filev: File_Ptr := new Chio.File_Type; end case; end record; function Make_File_Stream(F: File_Access; Direction: File_Mode) return Cell; -- with an existing open file function Make_File_Stream return Cell; -- with an unopened file function Make_String_Stream(Buffer_Size: Integer:= Default_Buffer_Size; Direction: File_Mode:= Input_Output) return Cell; function Open(File_Name: String; Mode: File_Mode) return Cell; procedure Close(File: Cell); function Streamp(C: Cell) return Boolean; -- function Streamp(C: Cell) return Cell; function Position(Str: Cell) return Integer; function Size(Str: Cell) return Integer; procedure Position(Str: Cell; P: Integer); --- OUTPUT --- function Put(Stream: Cell; C: Character; Really: Boolean:= True) return Integer; function Put(Stream: Cell; S: String; Really: Boolean:= True) return Integer; function Put(Stream, Obj: Cell; Really: Boolean:= True) return Integer; function Put(Obj: Cell) return String; procedure Put(Stream, Obj: Cell; Really: Boolean:= True); --- INPUT --- function Read(Stream: Cell; Inlist: Boolean:= False) return Cell; function Read(S: String) return Cell; --- non primitive I/O utilities --- function Read_First_Sexpr(Filename: String) return Cell; function Read_File_As_List(Filename: String) return Cell; procedure Append_Sexpr_To_File(Filename: String; Sexpr: Cell); procedure Create_File_From_Sexpr(Filename: String; Sexpr: Cell); --- DEBUG AND STAT PROCEDURES --- procedure Hash_Table_Stat; --- PREDEFINED SYMBOLS --- --- these variables are only written during the initialization of the niliada --- package, so they are 'thread safe'. NIL: Cell; T: Cell; EOF: Cell; Standard_Out: Cell; Standard_In: Cell; Standard_Err: Cell; --- predefined strings Null_String: Cell; --- EXCEPTIONS --- Invalid_Cell_Type: exception; Invalid_Stream_Type: exception; Hashtable_Full: exception; -- we must cultivate lazines... Input_Stream_Needed: exception; Output_Stream_Needed: exception; Alternative_Does_Not_Exist: exception; end Niliada; -- NILIADA - Lisp objects in Ada -- Copyright (c) 1999 Alexandru Dan Corlan MD -- with Text_Io; use Text_Io; with Ada.Tags; use Ada.Tags; with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with Ada.Characters.Handling; use Ada.Characters.Handling; with Unchecked_Deallocation; with System.Storage_elements; with System.Address_To_Access_Conversions; with Gnat.Os_Lib; use Gnat.Os_Lib; package body Niliada is Start_Bucket_Size: constant Integer:= 1001; Nsymbols: Integer := 0; Totss: Integer := 0; Hash_Bucket_Incr: constant Integer := 10; --- MEMORY MANAGEMENT --- procedure Free_Cell is new Unchecked_Deallocation(Cell_Root'Class, Cell_Root_Ptr); procedure Free_Hash_Bucket is new Unchecked_Deallocation(Hash_Bucket, Hash_Bucket_Ptr); procedure Free_String is new Unchecked_Deallocation(String, String_Access); procedure Finalize(Object: in out Cell) is begin if Object.P = null then -- Put("N"); null; else -- Put("F:"); -- Put(External_Tag(Object.P.all'Tag)); -- Put(Integer'Image(Integer(System.Storage_Elements.To_Integer(Object.P.all'address)))); -- Put_Line(Integer'Image(Object.P.Linkount)); Object.P.Linkount := Object.P.Linkount - 1; if Object.P.Linkount <= 0 then if Streamp(Object) and then Stream_Cell(Object.P.all).Mode=Str then Free_String(Stream_Cell(Object.P.all).Strv); Stream_Cell(Object.P.all).Strv := null; end if; Free(Object.P); Object.P := null; end if; end if; end Finalize; procedure Adjust(Object: in out Cell) is begin if Object.P = null then -- Put("n"); null; else -- Put("A:"); -- Put(External_Tag(Object.P.all'Tag)); -- Put(Integer'Image(Integer(System.Storage_Elements.To_Integer(Object.P.all'address)))); -- Put_Line(Integer'Image(Object.P.Linkount)); Object.P.Linkount := Object.P.Linkount + 1; end if; end Adjust; --- INTEGERS --- function Make_Integer(Int: Long_Long_Integer) return Cell is Rv: Cell; begin Rv.P := new Integer_Cell; Integer_Cell(Rv.P.all).Val := Int; return Rv; end Make_Integer; function Make_Integer(Int: Long_Integer) return Cell is Rv: Cell; begin Rv.P := new Integer_Cell; Integer_Cell(Rv.P.all).Val := Long_Long_Integer(Int); return Rv; end Make_Integer; function Make_Integer(Int: Integer) return Cell is Rv: Cell; begin Rv.P := new Integer_Cell; Integer_Cell(Rv.P.all).Val := Long_Long_Integer(Int); return Rv; end Make_Integer; function Integerp(C: Cell) return Boolean is begin if C/=Nil then return External_Tag(C.P.all'Tag)="NILIADA.INTEGER_CELL"; else return False; end if; end Integerp; function Integer_Of(C: Cell) return Integer is begin if not Numberp(C) then raise Invalid_Cell_Type; end if; if Integerp(C) then return Integer(Integer_Cell(C.P.all).Val); else return Integer(Float_Cell(C.P.all).Val); end if; end Integer_Of; function Integer_Of(C: Cell) return Long_Integer is begin if not Numberp(C) then raise Invalid_Cell_Type; end if; if Integerp(C) then return Long_Integer(Integer_Cell(C.P.all).Val); else return Long_Integer(Float_Cell(C.P.all).Val); end if; end Integer_Of; function Integer_Of(C: Cell) return Long_Long_Integer is begin if not Numberp(C) then raise Invalid_Cell_Type; end if; if Integerp(C) then return Long_Long_Integer(Integer_Cell(C.P.all).Val); else return Long_Long_Integer(Float_Cell(C.P.all).Val); end if; end Integer_Of; --- FLOATS --- function Make_Float(Int: Long_Long_Float) return Cell is Rv: Cell; begin Rv.P := new Float_Cell; Float_Cell(Rv.P.all).Val := Int; return Rv; end Make_Float; function Make_Float(Int: Long_Float) return Cell is Rv: Cell; begin Float_Cell(Rv.P.all).Val := Long_Long_Float(Int); return Rv; end Make_Float; function Make_Float(Int: Float) return Cell is Rv: Cell; begin Float_Cell(Rv.P.all).Val := Long_Long_Float(Int); return Rv; end Make_Float; function Floatp(C: Cell) return Boolean is begin if C/=Nil then return External_Tag(C.P.all'Tag)="NILIADA.FLOAT_CELL"; else return False; end if; end Floatp; function Float_Of(C: Cell) return Float is begin if not Numberp(C) then raise Invalid_Cell_Type; end if; if Integerp(C) then return Float(Integer_Cell(C.P.all).Val); else return Float(Float_Cell(C.P.all).Val); end if; end Float_Of; function Float_Of(C: Cell) return Long_Float is begin if not Numberp(C) then raise Invalid_Cell_Type; end if; if Integerp(C) then return Long_Float(Integer_Cell(C.P.all).Val); else return Long_Float(Float_Cell(C.P.all).Val); end if; end Float_Of; function Float_Of(C: Cell) return Long_Long_Float is begin if not Numberp(C) then raise Invalid_Cell_Type; end if; if Integerp(C) then return Long_Long_Float(Integer_Cell(C.P.all).Val); else return Long_Long_Float(Float_Cell(C.P.all).Val); end if; end Float_Of; --- Other numeric functions --- function Numberp(Cc: Cell) return Boolean is begin if Cc=NIL then return False; end if; return Integerp(Cc) or else Floatp(Cc); end Numberp; --- SYMBOLS --- function Symbolp(C: Cell) return Boolean is begin if C/=Nil then return External_Tag(C.P.all'Tag)="NILIADA.SYMBOL_CELL"; else return False; end if; end Symbolp; -- with 15000 symbols and 1001 entries in the table -- this hash function gave 15 +/- 5 symbols -- per entry; median 15, mean 15min 3, first Q 11, third Q 18, max 32 function Hash(S: String; Modulo: Integer) return Integer is Rv: Integer:= 1; begin for I in S'Range loop Rv := ((Rv + 129 * Character'Pos(S(I)) + 53) mod Modulo) + 1; end loop; return Rv; end Hash; protected type Symbol_Maker is procedure Ensure_Symbol(S: String; C: out Cell); procedure Hash_Table_Stat; procedure Initialize; private Symht: Cell; end Symbol_Maker; protected body Symbol_Maker is procedure Ensure_Symbol(S: String; C: out Cell) is -- make an interned symbol Rv: Cell; Hi: Integer; Hbp: Hash_Bucket_Ptr := null; -- new bucket in preparation begin -- first, try to locate the symbol in the hashtable Hi := Hash(S, Hashtable_Cell(Symht.P.all).Len); declare Hb: Hash_Bucket_Set renames Hashtable_Cell(Symht.P.all).Buckets; begin if Hb(Hi)/=null then -- there is a bucket here, maybe in it for I in Hb(Hi).all'Range loop if Hb(Hi).all(I).P/= null and then -- maybe this one Symbol_Cell(Hb(Hi).all(I).P.all).Name=S then -- yes, it is C := Hb(Hi).all(I); return; end if; end loop; end if; Nsymbols := Nsymbols + 1; Totss := Totss + S'Length; Rv.P := new Symbol_Cell(S'Length); Symbol_Cell(Rv.P.all).Name := S; loop if Hb(Hi)=null then -- intern in a new bucket Hb(Hi) := new Hash_Bucket(1..Hash_Bucket_Incr); -- Hb(Hi).all := (others => Nil); Hb(Hi).all(1) := Rv; C := Rv; return; end if; for I in Hb(Hi).all'Range loop if Hb(Hi).all(I).P = null then -- if space is free, intern! Hb(Hi).all(I) := Rv; C := Rv; return; end if; end loop; Hbp := new Hash_Bucket(1..(Hb(Hi).all'Length+Hash_Bucket_Incr)); for I in Hb(Hi).all'Range loop Hbp(I) := Hb(Hi).all(I); end loop; Hbp(Hb(Hi).all'Length+1) := Rv; Free_Hash_Bucket(Hb(Hi)); Hb(Hi) := Hbp; end loop; end; end Ensure_Symbol; procedure Hash_Table_Stat is Hs: Integer := Hashtable_Cell(Symht.P.all).Len; Hb: Hash_Bucket_Set renames Hashtable_Cell(Symht.P.all).Buckets; begin for I in 1..Hs loop if Hb(I)/=null then for J in Hb(I).all'Range loop if Nullp(Hb(I).all(J)) then Put(Integer'Image(J-1)); exit; end if; end loop; else Put(" 0"); end if; end loop; end Hash_Table_Stat; procedure Initialize is begin Symht.P := new Hashtable_Cell(Start_Bucket_Size); Symht.P.Linkount := 1; end Initialize; end Symbol_Maker; Oblist: Symbol_Maker; function Intern(S: String) return Cell is Rv: Cell; begin Oblist.Ensure_Symbol(S,Rv); return Rv; end Intern; procedure Hash_Table_Stat is begin Oblist.Hash_Table_Stat; end Hash_Table_Stat; function Symbol_Name(Cc: Cell) return String is begin return Symbol_Cell(Cc.P.all).Name; end Symbol_Name; --- STRINGS --- function Make_String(S: String) return Cell is Rv: Cell; begin Rv.P := new String_Cell(S'Length); String_Cell(Rv.P.all).Str := "" & S; return Rv; end Make_String; function Stringp(Cc: Cell) return Boolean is begin if Cc/=Nil then return External_Tag(Cc.P.all'Tag)="NILIADA.STRING_CELL"; else return False; end if; end Stringp; function String_Of(Cc: Cell) return String is begin if not Stringp(Cc) and then not Symbolp(Cc) then raise Invalid_Cell_Type; end if; if Symbolp(Cc) then return Symbol_Name(Cc); end if; return String_Cell(Cc.P.all).Str; end String_Of; --- BIT VECTORS --- function Make_Bit_Vector(Len: Integer; Fill: Integer:=0) return Cell is Rv: Cell; begin Rv.P := new Bit_Vector_Cell(Len); Bit_Vector_Cell(Rv.P.all).Fill := Fill; return Rv; end Make_Bit_Vector; function Bit_Vector_P(Bv: Cell) return Boolean is begin if Bv/=Nil then return External_Tag(Bv.P.all'Tag)="NILIADA.BIT_VECTOR_CELL"; else return False; end if; end Bit_Vector_P; function Elt(Bv: Cell; I: Integer) return Boolean is begin if I<1 or else I>Bit_Vector_Cell(Bv.P.all).Fill then raise Constraint_Error; end if; return Bit_Vector_Cell(Bv.P.all).Bv(I); end Elt; procedure Set(Bv: Cell; I: Integer; Val: Boolean) is begin if I<1 or else I>Bit_Vector_Cell(Bv.P.all).Fill then raise Constraint_Error; end if; Bit_Vector_Cell(Bv.P.all).Bv(I) := Val; end Set; procedure Append(Bv: Cell; Val: Boolean) is begin if Bit_Vector_Cell(Bv.P.all).Fill >= Bit_Vector_Cell(Bv.P.all).Len then raise Constraint_Error; end if; Bit_Vector_Cell(Bv.P.all).Fill := Bit_Vector_Cell(Bv.P.all).Fill + 1; Bit_Vector_Cell(Bv.P.all).Bv(Bit_Vector_Cell(Bv.P.all).Fill) := Val; end Append; function Bit_And(Bv1,Bv2: Cell) return Cell is Rv: Cell:= Make_Bit_Vector(Length(Bv1)); Nl: Integer; begin if Bit_Vector_Cell(Bv1.P.all).Fill=Bit_Vector_Cell(Bv2.P.all).Fill then Nl := Bit_Vector_Cell(Bv1.P.all).Fill; Bit_Vector_Cell(Rv.P.all).Fill := Nl; Bit_Vector_Cell(Rv.P.all).Bv(1..Nl) := Bit_Vector_Cell(Bv1.P.all).Bv(1..Nl) and Bit_Vector_Cell(Bv2.P.all).Bv(1..Nl); return Rv; end if; Nl := Bit_Vector_Cell(Bv1.P.all).Fill; if Nl>Bit_Vector_Cell(Bv2.P.all).Fill then Nl := Bit_Vector_Cell(Bv2.P.all).Fill; end if; for I in 1..Nl loop Append(Rv,Bit_Vector_Cell(Bv1.P.all).Bv(I) and then Bit_Vector_Cell(Bv2.P.all).Bv(I)); end loop; return Rv; end Bit_And; function Bit_Or(Bv1,Bv2: Cell) return Cell is Rv: Cell:= Make_Bit_Vector(Length(Bv1)); Nl: Integer; begin if Bit_Vector_Cell(Bv1.P.all).Fill=Bit_Vector_Cell(Bv2.P.all).Fill then Nl := Bit_Vector_Cell(Bv1.P.all).Fill; Bit_Vector_Cell(Rv.P.all).Fill := Nl; Bit_Vector_Cell(Rv.P.all).Bv(1..Nl) := Bit_Vector_Cell(Bv1.P.all).Bv(1..Nl) or Bit_Vector_Cell(Bv2.P.all).Bv(1..Nl); return Rv; end if; Nl := Bit_Vector_Cell(Bv1.P.all).Fill; if Nl>Bit_Vector_Cell(Bv2.P.all).Fill then Nl := Bit_Vector_Cell(Bv2.P.all).Fill; end if; for I in 1..Nl loop Append(Rv,Bit_Vector_Cell(Bv1.P.all).Bv(I) or else Bit_Vector_Cell(Bv2.P.all).Bv(I)); end loop; return Rv; end Bit_Or; function Bit_Not(Bv: Cell) return Cell is Rv: Cell:= Make_Bit_Vector(Length(Bv)); Nl: Integer; begin Nl := Bit_Vector_Cell(Bv.P.all).Fill; Bit_Vector_Cell(Rv.P.all).Fill := Nl; Bit_Vector_Cell(Rv.P.all).Bv(1..Nl) := not Bit_Vector_Cell(Bv.P.all).Bv(1..Nl); return Rv; -- for I in 1..Bit_Vector_Cell(Bv.P.all).Fill loop -- Append(Rv, not Bit_Vector_Cell(Bv.P.all).Bv(I)); -- end loop; -- return Rv; end Bit_Not; function Bit_Count(Bv: Cell) return Integer is Rv: Integer:= 0; begin for I in 1..Bit_Vector_Cell(Bv.P.all).Fill loop if Bit_Vector_Cell(Bv.P.all).Bv(I) then Rv := Rv + 1; end if; end loop; return Rv; end Bit_Count; function Slow_First_Bit(Bv: Cell) return Natural is begin for I in 1..Bit_Vector_Cell(Bv.P.all).Fill loop if Bit_Vector_Cell(Bv.P.all).Bv(I) then return I; end if; end loop; return 0; -- no bit set in this vector; end Slow_First_Bit; function Slow_Next_Bit(Bv: Cell; Crt: Natural) return Natural is begin for I in (Crt+1)..Bit_Vector_Cell(Bv.P.all).Fill loop if Bit_Vector_Cell(Bv.P.all).Bv(I) then return I; end if; end loop; return 0; -- no more bits set in this vector; end Slow_Next_Bit; --- ultrafast versions of bit operations, may be implementation dependent --- these are subtantially faster if the bitvector is relatively sparse type Dword is mod 2**32; Singles: array(1..32) of Dword; -- see initialization below function Fast_First_Bit(Bv: Cell) return Natural is type Siv is array(Integer range 1..(Bit_Vector_Cell(Bv.P.all).Fill/32)+1) of Dword; pragma Pack(Siv); package Siv_Ptr_Conv is new System.Address_To_Access_Conversions(Siv); Spt: Siv_Ptr_Conv.Object_Pointer; Bpt: System.Address := Bit_Vector_Cell(Bv.P.all).Bv'Address; Totl: Natural; begin Totl:= Bit_Vector_Cell(Bv.P.all).Fill; Spt := Siv_Ptr_Conv.To_Pointer(Bpt); for I in 1..((Totl-1)/32) loop if Spt.all(I)/=0 then for J in 1..32 loop if (Singles(J) and Spt.all(I))/=0 then return J+(I-1)*32; end if; end loop; end if; end loop; for J in 1..((Totl-1) mod 32)+1 loop if (Singles(J) and Spt.all(((Totl-1)/32)+1))/=0 then return J+((Totl-1)/32)*32; end if; end loop; return 0; end Fast_First_Bit; function Fast_Next_Bit(Bv: Cell; Crt: Natural) return Natural is type Siv is array(Integer range 1..(Bit_Vector_Cell(Bv.P.all).Fill/32)+1) of Dword; pragma Pack(Siv); package Siv_Ptr_Conv is new System.Address_To_Access_Conversions(Siv); Spt: Siv_Ptr_Conv.Object_Pointer; Bpt: System.Address := Bit_Vector_Cell(Bv.P.all).Bv'Address; Totl: Natural; Mask: Dword; Ncr: Natural:= Crt+1; function Word_Of(N: Natural) return Natural; pragma Inline(Word_Of); function Word_Of(N: Natural) return Natural is begin return ((N-1)/32) + 1; end Word_Of; function Bit_Of(N: Natural) return Natural; pragma Inline(Bit_Of); function Bit_Of(N: Natural) return Natural is begin return ((N-1) mod 32) + 1; end Bit_Of; begin Totl:= Bit_Vector_Cell(Bv.P.all).Fill; if Ncr>Totl then return 0; end if; Mask := Dword((2**32-1)-(2**(Crt mod 32)-1)); Spt := Siv_Ptr_Conv.To_Pointer(Bpt); if Word_Of(Ncr)=Word_Of(Totl) then for J in Bit_Of(Ncr)..Bit_Of(Totl) loop if (Singles(J) and Spt.all(Word_Of(Ncr)))/=0 then return J+(Word_Of(Ncr)-1)*32; end if; end loop; return 0; else for J in Bit_Of(Ncr)..32 loop if (Singles(J) and Spt.all(Word_Of(Ncr)))/=0 then return J+(Word_Of(Ncr)-1)*32; end if; end loop; end if; for I in Word_Of(Ncr)+1..Word_Of(Totl)-1 loop if Spt.all(I)/=0 then for J in 1 .. 32 loop if (Singles(J) and Spt.all(I))/=0 then return J+(I-1)*32; end if; end loop; end if; end loop; for J in 1..Bit_Of(Totl) loop if (Singles(J) and Spt.all(Word_Of(Totl)))/=0 then return J+32*(Word_Of(Totl)-1); end if; end loop; return 0; end Fast_Next_Bit; --- LISTS --- function Consp(Cc: Cell) return Boolean is begin if Cc/=Nil then return External_Tag(Cc.P.all'Tag)="NILIADA.CONS_CELL"; else return False; end if; end Consp; function Listp(Cc: Cell) return Boolean is begin return Cc=NIL or else Consp(Cc); end Listp; function Nullp(Cc: Cell) return Boolean is begin return Cc=NIL; end Nullp; procedure Rplaca(Where, By: Cell) is begin if not Consp(Where) then raise Invalid_Cell_Type; end if; Cons_Cell(Where.P.all).Head := By; end Rplaca; procedure Rplacd(Where, By: Cell) is begin if not Consp(Where) then raise Invalid_Cell_Type; end if; Cons_Cell(Where.P.all).Tail := By; end Rplacd; function Cons(Car, Cdr: Cell) return Cell is Rv: Cell; begin Rv.P := new Cons_Cell; Cons_Cell(Rv.P.all).Head := Car; Cons_Cell(Rv.P.all).Tail := Cdr; return Rv; end Cons; function Car(Cc: Cell) return Cell is begin if not Consp(Cc) then raise Invalid_Cell_Type; end if; return Cons_Cell(Cc.P.all).Head; end Car; function Cdr(Cc: Cell) return Cell is begin if not Consp(Cc) then raise Invalid_Cell_Type; end if; return Cons_Cell(Cc.P.all).Tail; end Cdr; function Caar(Cc: Cell) return Cell is begin return Car(Car(Cc)); end Caar; function Cadr(Cc: Cell) return Cell is begin return Car(Cdr(Cc)); end Cadr; function Cdar(Cc: Cell) return Cell is begin return Cdr(Car(Cc)); end Cdar; function Cddr(Cc: Cell) return Cell is begin return Cdr(Cdr(Cc)); end Cddr; function Caaar(Cc: Cell) return Cell is begin return Car(Car(Car(Cc))); end Caaar; function Caadr(Cc: Cell) return Cell is begin return Car(Car(Cdr(Cc))); end Caadr; function Cadar(Cc: Cell) return Cell is begin return Car(Cdr(Car(Cc))); end Cadar; function Caddr(Cc: Cell) return Cell is begin return Car(Cdr(Cdr(Cc))); end Caddr; function Cdaar(Cc: Cell) return Cell is begin return Cdr(Car(Car(Cc))); end Cdaar; function Cdadr(Cc: Cell) return Cell is begin return Cdr(Car(Cdr(Cc))); end Cdadr; function Cddar(Cc: Cell) return Cell is begin return Cdr(Cdr(Car(Cc))); end Cddar; function Cdddr(Cc: Cell) return Cell is begin return Cdr(Cdr(Cdr(Cc))); end Cdddr; function Alist_Value(Alist: Cell; Key: String) return String is Msym: Cell := Intern(Key); Mlist: Cell := Alist; begin while Mlist /= Nil loop if Car(Mlist)=Msym then if Stringp(Cadr(Mlist)) then return String_Of(Cadr(Mlist)); elsif Symbolp(Cadr(Mlist)) then return Symbol_Name(Cadr(Mlist)); elsif Integerp(Cadr(Mlist)) then return Long_Long_Integer'Image(Integer_Of(Cadr(Mlist))); else return ""; end if; end if; Mlist := Cddr(Mlist); end loop; return ""; end Alist_Value; function Alist_Value(Alist: Cell; Key: String) return Cell is Msym: Cell := Intern(Key); Mlist: Cell := Alist; begin while Mlist /= Nil loop if Car(Mlist)=Msym then return Cadr(Mlist); end if; Mlist := Cddr(Mlist); end loop; return Make_String(""); end Alist_Value; function Alist_Value(Alist, Key: Cell) return String is Msym: Cell := Key; Mlist: Cell := Alist; begin while Mlist /= Nil loop if Car(Mlist)=Msym then if Stringp(Cadr(Mlist)) then return String_Of(Cadr(Mlist)); elsif Symbolp(Cadr(Mlist)) then return Symbol_Name(Cadr(Mlist)); elsif Integerp(Cadr(Mlist)) then return Long_Long_Integer'Image(Integer_Of(Cadr(Mlist))); else return ""; end if; end if; Mlist := Cddr(Mlist); end loop; return ""; end Alist_Value; function Alist_Value(Alist, Key: Cell) return Cell is Msym: Cell := Key; Mlist: Cell := Alist; begin while Mlist /= Nil loop if Car(Mlist)=Msym then return Cadr(Mlist); end if; Mlist := Cddr(Mlist); end loop; return Make_String(""); end Alist_Value; function Alist_Has_Value(Alist, Key: Cell) return Boolean is Msym: Cell := Key; Mlist: Cell := Alist; begin while Mlist /= Nil loop if Car(Mlist)=Msym then return True; end if; Mlist := Cddr(Mlist); end loop; return False; end Alist_Has_Value; function Alist_Has_Value(Alist: Cell; Key: String) return Boolean is Msym: Cell := Intern(Key); Mlist: Cell := Alist; begin while Mlist /= Nil loop if Car(Mlist)=Msym then return True; end if; Mlist := Cddr(Mlist); end loop; return False; end Alist_Has_Value; --- SEQUENCES --- function Length(Cc: Cell) return Integer is begin if Stringp(Cc) then return String_Cell(Cc.P.all).Str'Length; end if; if Bit_Vector_P(Cc) then return Bit_Vector_Cell(Cc.P.all).Fill; end if; if Listp(Cc) then declare L: Integer:= 0; Cx: Cell:= Cc; begin while Cx/=NIL loop L := L+1; Cx := Cdr(Cx); end loop; return L; end; end if; raise Invalid_Cell_Type; end Length; --- STREAMS --- function Make_File_Stream(F: File_Access; Direction: File_Mode) return Cell is Rv: Cell; begin Rv.P := new Stream_Cell(File); Stream_Cell(Rv.P.all).Const_Filev := F; Stream_Cell(Rv.P.all).Direction := Direction; return Rv; end Make_File_Stream; function Make_File_Stream return Cell is Rv: Cell; begin Rv.P := new Stream_Cell(New_File); return Rv; end Make_File_Stream; function Make_String_Stream(Buffer_Size: Integer:= Default_Buffer_Size; Direction: File_Mode:= Input_Output) return Cell is Rv: Cell; begin Rv.P := new Stream_Cell(Str); Stream_Cell(Rv.P.all).Strv := new String(1..Buffer_Size); Stream_Cell(Rv.P.all).Direction := Direction; return Rv; end Make_String_Stream; function Streamp(C: Cell) return Boolean is begin if C/=Nil then return External_Tag(C.P.all'Tag)="NILIADA.STREAM_CELL"; else return False; end if; end Streamp; function Open(File_Name: String; Mode: File_Mode) return Cell is Rv: Cell:= Make_File_Stream; J: Integer; begin Stream_Cell(Rv.P.all).Direction := Mode; if Is_Regular_File(File_Name) then case Mode is when Input => Chio.Open(Stream_Cell(Rv.P.all).Filev.all, Chio.In_File, File_Name); Chio.Set_Index(Stream_Cell(Rv.P.all).Filev.all, 1); return Rv; when Output => Chio.Open(Stream_Cell(Rv.P.all).Filev.all, Chio.Out_File, File_Name); Chio.Set_Index(Stream_Cell(Rv.P.all).Filev.all, 1); return Rv; when Input_Output => Chio.Open(Stream_Cell(Rv.P.all).Filev.all, Chio.Inout_File, File_Name); Chio.Set_Index(Stream_Cell(Rv.P.all).Filev.all, 1); return Rv; when Append => Chio.Open(Stream_Cell(Rv.P.all).Filev.all, Chio.Inout_File, File_Name); J := Integer(Chio.Size(Stream_Cell(Rv.P.all).Filev.all)); Chio.Set_Index(Stream_Cell(Rv.P.all).Filev.all, Chio.Positive_Count(J+1)); return Rv; when Closed => null; end case; else Stream_Cell(Rv.P.all).Direction := Mode; case Mode is when Input => Chio.Create(Stream_Cell(Rv.P.all).Filev.all, Chio.In_File, File_Name); return Rv; when Output => Chio.Create(Stream_Cell(Rv.P.all).Filev.all, Chio.Out_File, File_Name); return Rv; when Input_Output => Chio.Create(Stream_Cell(Rv.P.all).Filev.all, Chio.Inout_File, File_Name); return Rv; when Append => Chio.Create(Stream_Cell(Rv.P.all).Filev.all, Chio.Inout_File, File_Name); return Rv; when Closed => null; end case; end if; return Rv; end Open; procedure Close(File: Cell) is begin Chio.Close(Stream_Cell(File.P.all).Filev.all); Stream_Cell(File.P.all).Direction := Closed; end Close; function Position(Str: Cell) return Integer is begin if not Streamp(Str) then raise Invalid_Cell_Type; end if; if Stream_Cell(Str.P.all).Mode /= New_File then raise Invalid_Stream_Type; end if; return Integer(Chio.Index(Stream_Cell(Str.P.all).Filev.all)); end Position; procedure Position(Str: Cell; P: Integer) is begin if not Streamp(Str) then raise Invalid_Cell_Type; end if; if Stream_Cell(Str.P.all).Mode /= New_File then raise Invalid_Stream_Type; end if; Chio.Set_Index(Stream_Cell(Str.P.all).Filev.all,Chio.Positive_Count(P)); end Position; function Size(Str: Cell) return Integer is begin if not Streamp(Str) then raise Invalid_Cell_Type; end if; if Stream_Cell(Str.P.all).Mode /= New_File then raise Invalid_Stream_Type; end if; return Integer(Chio.Size(Stream_Cell(Str.P.all).Filev.all)); end size; -- OUTPUT -- function Put(Stream: Cell; C: Character; Really: Boolean:= True) return Integer is begin if not Really then return 1; end if; if not Streamp(Stream) then raise Invalid_Cell_Type; end if; if Stream_Cell(Stream.P.all).Direction /= Output and then Stream_Cell(Stream.P.all).Direction /= Input_Output and then Stream_Cell(Stream.P.all).Direction /= Append then raise Output_Stream_Needed; end if; declare Stre: Stream_Cell renames Stream_Cell(Stream.P.all); begin if Stre.Mode=Str then Stre.Strv.all(Stre.Write_Ix) := C; if Stre.Write_Ix >= Stre.Strv.all'Length then Stre.Write_Ix := 1; else Stre.Write_Ix := Stre.Write_Ix + 1; end if; return 1; -- should raise about read_ix overwriting around here... end if; if Stre.Mode=File then Put(Stre.Const_Filev.all, C); return 1; end if; if Stre.Mode=New_File then Chio.Write(Stre.Filev.all, C); return 1; end if; end; return 0; end Put; function Put(Stream: Cell; S: String; Really: Boolean:= True) return Integer is Len: Integer := 0; begin for I in S'Range loop Len := Len + Put(Stream, S(I), Really); end loop; return Len; end Put; function Put(Stream, Obj: Cell; Really: Boolean:= True) return Integer is Len: Integer := 0; begin if Nullp(Obj) then return Put(Stream, "()", Really); end if; if Symbolp(Obj) then declare Sn: String:= Symbol_Name(Obj); Digip: Boolean:= True; begin for I in Sn'Range loop if not Is_Digit(Sn(I)) and then Sn(I)/='.' and then Sn(I)/='-' and then Sn(I)/='+' then Digip := False; exit; end if; end loop; for I in Sn'Range loop if not Is_Graphic(Sn(I)) or Sn(I)='(' or Sn(I)=')' or Sn(I)='.' or Sn(I)='|' or Sn(I)='\' or Sn(I)='"' or Sn(I)='#' or Digip then Len := Len + Put(Stream, '|', Really); for I in Sn'Range loop if not Is_Graphic(Sn(I)) or Sn(I)='(' or Sn(I)=')' or Sn(I)='.' or Sn(I)='|' or Sn(I)='\' or Sn(I)='"' or Sn(I)='#' then Len := Len+Put(Stream, '\', Really); end if; Len := Len+Put(Stream, Sn(I), Really); end loop; Len := Len+Put(Stream, '|', Really); return Len; end if; end loop; return Put(Stream, Sn, Really); end; end if; if Integerp(Obj) then return Put(Stream, Long_Long_Integer'Image(Integer_Of(Obj)), Really); end if; if Floatp(Obj) then return Put(Stream, Long_Long_Float'Image(Float_Of(Obj)), Really); end if; if Stringp(Obj) then Len := Put(Stream, '"', Really); declare Sn: String:= String_Of(Obj); begin for I in Sn'Range loop if Sn(I)='"' or not Is_Graphic(Sn(I)) or Sn(I)='\' then Len := Len+Put(Stream, '\', Really); end if; Len := Len+Put(Stream, Sn(I), Really); end loop; end; Len := Len+Put(Stream, '"', Really); return Len; end if; if Consp(Obj) then Len := Put(Stream, "(", Really); Len := Len+Put(Stream, Car(Obj), Really); declare Cx: Cell:= Cdr(Obj); begin while Cx /= NIL loop Len := Len+Put(Stream, ' ', Really); if not Consp(Cx) then Len := Len+Put(Stream, '.', Really); Len := Len+Put(Stream, ' ', Really); Len := Len+Put(Stream, Cx, Really); Len := Len+Put(Stream, ')', Really); return Len; else Len := Len+Put(Stream, Car(Cx), Really); Cx := Cdr(Cx); end if; end loop; end; Len := Len+Put(Stream, ')', Really); return Len; end if; raise Invalid_Cell_Type; end Put; procedure Put(Stream, Obj: Cell; Really: Boolean:= True) is Waste: Integer; begin Waste := Put(Stream, Obj, Really); end Put; function Put(Obj: Cell) return String is Sstr: Cell; Len: Integer; begin Sstr := Make_String_Stream; Len := Put(Sstr,Obj); return Stream_Cell(Sstr.P.all).Strv(1..Len); end Put; -- INPUT -- function Get(Stream: Cell) return Character is Rv: Character; St: Stream_Cell renames Stream_Cell(Stream.P.all); begin if not Streamp(Stream) then raise Invalid_Cell_Type; end if; if st.Direction /= Input and then St.Direction /= Input_Output then raise Input_Stream_Needed; end if; if st.Ungetcf then st.Ungetcf := False; return st.Ungetc; end if; if st.Mode=New_File then Chio.Read(St.Filev.all, Rv); return Rv; end if; if St.Mode=File then Get_Immediate(St.Const_Filev.all, Rv); return Rv; end if; if St.Mode=Str then Rv := St.Strv(St.Read_Ix); St.Read_Ix := St.Read_Ix+1; if St.Read_Ix > St.Strv'Length then St.Read_Ix := 1; end if; return Rv; end if; raise Alternative_Does_Not_Exist; end Get; procedure Unget(Stream: Cell; C: Character) is St: Stream_Cell renames Stream_Cell(Stream.P.all); begin if not Streamp(Stream) then raise Invalid_Cell_Type; end if; if st.Direction /= Input and then St.Direction /= Input_Output then raise Input_Stream_Needed; end if; St.Ungetc := C; St.Ungetcf := True; end Unget; function Next_Non_Blank(Stream: Cell) return Character is C: Character; begin loop C := Get(Stream); if C/=HT and then C/=Space and then C/=LF and then C/=CR then Unget(Stream, C); return C; end if; end loop; end Next_Non_Blank; function Reverse_List(C: Cell) return Cell is Rv: Cell:= NIL; Cc: Cell:= C; Ccc: Cell; begin while Cc/= NIL loop Rv := Cons(Car(Cc), Rv); Cc := Cdr(Cc); end loop; return Rv; end Reverse_List; function Append_List(A,B: Cell) return Cell is Rv, Aa, Bb: Cell; begin Rv := Nil; Aa := A; Bb := B; while Aa/=Nil loop Rv := Cons(Car(Aa),Rv); Aa := Cdr(Aa); end loop; while Bb/=Nil loop Rv := Cons(Car(Bb),Rv); Bb := Cdr(Bb); end loop; return Reverse_List(Rv); end Append_List; function Member(A,L: Cell) return Boolean is Ll: Cell:= L; begin while Ll/=Nil and then Consp(Ll) loop if Car(Ll)=A then return True; end if; Ll := Cdr(Ll); end loop; return False; end Member; function Intersect(L,M: Cell) return Cell is R: Cell:= Nil; X: Cell:= L; begin while X/=Nil loop if Member(Car(X),M) and then not Member(Car(X),R) then R := Cons(Car(X),R); end if; X := Cdr(X); end loop; return R; end Intersect; function Union(L,M: Cell) return Cell is R: Cell:= Nil; X: Cell; begin X := L; while X/=Nil loop if not Member(Car(X),R) then R := Cons(Car(X),R); end if; X := Cdr(X); end loop; X := M; while X/=Nil loop if not Member(Car(X),R) then R := Cons(Car(X),R); end if; X := Cdr(X); end loop; return R; end Union; function Naive_Difference(L,M: Cell) return Cell is -- elements in L and not in M R: Cell:= Nil; X: Cell:= L; begin while X/=Nil loop if not Member(Car(X),M) and then not Member(Car(X),R) then R := Cons(Car(X),R); end if; X := Cdr(X); end loop; return R; end Naive_Difference; function Difference(L,M: Cell) return Cell is -- elements in L and not in M R: Cell:= Nil; X: Cell:= L; begin while X/=Nil loop if not Member(Car(X),M) then R := Cons(Car(X),R); end if; X := Cdr(X); end loop; return R; end Difference; -- type String_Access is access String; function Read(Stream: Cell; Inlist: Boolean:= False) return Cell is C: Character; Rv: Cell; begin C := Next_Non_Blank(Stream); if C='(' then C := Get(Stream); -- the same Rv := NIL; loop C := Next_Non_Blank(Stream); if C/=')' then Rv := Cons(Read(Stream, True), Rv); else C := Get(Stream); -- the ')' return Reverse_List(Rv); end if; end loop; end if; if C='"' then declare S: String(1..20_000); -- silly limitation, should be small and reallocated Si :Integer := 1; begin C := Get(Stream); -- the same double quote loop C := Get(Stream); if C='"' then Si := Si-1; return Make_String(S(1..Si)); elsif C='\' then C := Get(Stream); if C='n' then C := LF; elsif C='t' then C := HT; elsif C='r' then C := CR; end if; end if; S(Si) := C; Si := Si + 1; -- reallocate here if necessary end loop; end; end if; -- explicit symbol if C='|' then declare S: String(1..200); -- silly limitation, -- should be small and reallocated Si : Integer := 1; begin C := Get(Stream); -- the same double quote loop C := Get(Stream); if C='|' then Si := Si-1; return Intern(S(1..Si)); elsif C='\' then C := Get(Stream); if C='n' then C := LF; elsif C='t' then C := HT; elsif C='r' then C := CR; end if; elsif C=LF or C=CR then Si := Si-1; return Intern(S(1..Si)); end if; S(Si) := C; Si := Si + 1; -- reallocate here if necessary end loop; end; end if; -- accumulate an atom declare S: String(1..200); -- should also be small and reallocated Si: Integer := 1; I: Integer:= 1; Ndots: Integer:= 0; Nes: Integer:= 0; Ndigits: Integer:= 0; Iv: Long_Long_Integer; begin loop C := Get(Stream); if C=Space or C=HT or C=LF or C=CR or (C=')' and Inlist) then -- it must be number or symbol now... Unget(Stream, C); Si := Si-1; if S(1)='+' or S(1)='-' then -- maybe a signed number if Si>1 then I := 2; else return Intern(S(1..1)); end if; end if; while I<=Si loop if S(I)/='.' and S(I)/= 'e' and S(I)/='E' and S(I)/='-' and S(I)/='+' and not Is_Digit(S(I)) then return Intern(S(1..Si)); end if; if Is_Digit(S(I)) then Ndigits := Ndigits+1; end if; if S(I)='e' or S(I)='E' then if I=Si or I=1 then return Intern(S(1..Si)); end if; if not(I>1 and (Is_Digit(S(I-1)) or S(I-1)='.')) or Nes/=0 then return Intern(S(1..Si)); end if; Nes := Nes + 1; end if; if S(I)='.' then if I=Si and Ndigits=0 then return Intern(S(1..Si)); end if; if Ndots /= 0 then return Intern(S(1..Si)); end if; Ndots := Ndots + 1; end if; if S(I)='+' or S(I)='-' then if S(I-1)/='e' and then S(I-1)/='E' then return Intern(S(1..Si)); end if; end if; I := I+1; end loop; if Ndots=0 and Nes=0 then Iv := 0; I := 1; if S(I)='+' or S(I)='-' then I := 1+1; end if; while I<=Si loop Iv := Iv * 10 + Character'Pos(S(I)) - Character'Pos('0'); I := I+1; end loop; if S(1)='-' then Iv := -Iv; end if; return Make_Integer(Iv); end if; return Make_Float(Long_Long_Float'Value(S(1..Si))); elsif C='\' then C := Get(Stream); if C='n' then C := LF; elsif C='t' then C := HT; elsif C='r' then C := CR; end if; end if; S(Si) := C; Si := Si + 1; -- reallocate here if necessary end loop; end; exception when End_Error => return EOF; end Read; function Read(S: String) return Cell is Sstr: Cell; begin Sstr := Make_String_Stream; Stream_Cell(Sstr.P.all).Strv(1..(S'Length+1)) := S & " "; return Read(Sstr); end Read; --- non primitive I/O utilities --- function Read_First_Sexpr(Filename: String) return Cell is Fl: Cell; Rv: Cell; begin Fl := Open(Filename, Input); Rv := Read(Fl); Close(Fl); return Rv; end Read_First_Sexpr; function Read_File_As_List(Filename: String) return Cell is Fl: Cell; Ne: Cell; Rv: Cell := Nil; begin Fl := Open(Filename, Input); loop Ne := Read(Fl); if Ne=EOF then exit; else Rv := Cons(Ne,Rv); end if; end loop; Close(Fl); return Reverse_List(Rv); end Read_File_As_List; procedure Append_Sexpr_To_File(Filename: String; Sexpr: Cell) is Strm: Cell; begin Strm := Open(Filename, Append); Put(Strm, Sexpr); Close(Strm); end Append_Sexpr_To_File; procedure Create_File_From_Sexpr(Filename: String; Sexpr: Cell) is Strm: Cell; Ft: File_Type; begin Create(Ft, Out_File, Filename); Close(Ft); Strm := Open(Filename, Output); Put(Strm, Sexpr); Close(Strm); end Create_File_From_Sexpr; begin for I in 1..32 loop Singles(I) := 2**(I-1); end loop; Oblist.Initialize; T := Intern("t"); Nil.P := null; EOF := Intern("end-of-file"); Standard_Out := Make_File_Stream(Standard_Output, Output); Standard_In := Make_File_Stream(Standard_Input, Input); Standard_Err := Make_File_Stream(Standard_Error, Output); Null_String := Make_String(""); end Niliada; with Niliada; use Niliada; with Text_Io; use Text_Io; procedure Nilpro is Cc, Cc1, Cc2: Cell; begin -- Put("Size of cell: "); -- Put_Line(Integer'Image(Cell'Size)); loop Cc := Read(Standard_In); if Cc=EOF then Put_Line("Hash table statistics:"); Hash_Table_Stat; return; end if; Put(Standard_Out, Cc); new_Line(Standard_Output); -- Free(Cc); end loop; end Nilpro; with Niliada; use Niliada; with Text_Io; use Text_Io; with Ada.Command_Line; use Ada.Command_Line; procedure Polynilpro is task type Read_Also_A_File is pragma Storage_Size(10_240_000); end Read_Also_A_File; task type Read_Standard_Input is pragma Storage_Size(10_240_000); end Read_Standard_Input; task body Read_Also_A_File is Ff, Dd: Cell; begin Put_Line(Integer'Image(Read_Also_A_File'Storage_Size)); if Argument_Count>0 then Ff := Open(Argument(1),Input); loop Dd := Read(Ff); if Dd=EOF then exit; end if; Put(Standard_Err, Dd); end loop; Close(Ff); end if; exception when others => Put_Line("Bad situation in task 'read_also_a_file'"); end Read_Also_A_File; task body Read_Standard_Input is Cc, Cc1, Cc2: Cell; begin loop Cc := Read(Standard_In); if Cc=EOF then exit; end if; Put(Standard_Out, Cc); new_Line(Standard_Output); null; end loop; end Read_Standard_Input; T1: Read_Also_A_File; T2: Read_Standard_Input; begin Put_Line("Hash table statistics:"); Hash_Table_Stat; end Polynilpro; with Niliada; use Niliada; with Text_Io; use Text_Io; procedure Snilpro is Cc, Cc1, Cc2: Cell; begin loop Cc := Read(Standard_In); if Cc=EOF then Put_Line("Hash table statistics:"); Hash_Table_Stat; return; end if; Put(Standard_Out, Cc); Put_Line("String version: "); Put(Put(Cc)); Put_Line(""); Put_Line("Reread string version: "); Put(Standard_Out, Read(Put(Cc))); new_Line(Standard_Output); end loop; end Snilpro; with Niliada; use Niliada; with Text_Io; use Text_Io; procedure Trylongl is C: Cell:= Nil; function Addints(Int: Integer) return Cell is begin if Int>0 then Put(Integer'Image(Int)); return Cons(Make_Integer(Int),Addints(Int-1)); else return Nil; end if; end Addints; begin C := Addints(10_000); Put_Line("Done"); end Trylongl; with Niliada; use Niliada; with Text_Io; use Text_Io; with Calendar; use Calendar; procedure Nilbench is H: Cell; T: Time; begin T := Clock; for I in 1..1_000 loop H := Cons(Nil,Nil); end loop; Put_Line("Thousand conses: " & Duration'Image(Clock-T)); T := Clock; for I in 1..1_000 loop H := Intern("H" & Integer'Image(I)); end loop; Put_Line("Thousand new interns: " & Duration'Image(Clock-T)); T := Clock; for I in 1..1_000 loop H := Intern("H" & Integer'Image(I)); end loop; Put_Line("Thousand remade interns: " & Duration'Image(Clock-T)); T := Clock; H := Nil; for I in 1..1_000 loop H := Cons(Intern("H" & Integer'Image(I)), H); end loop; Put_Line("Thousand remade interns + persistent conses: " & Duration'Image(Clock-T)); T := Clock; H := Difference(H, Cons(Intern("H" & Integer'Image(555)), Nil)); Put_Line("List of thousand - 1: " & Duration'Image(Clock-T)); end Nilbench; with Niliada; use Niliada; with Text_Io; use Text_Io; with Calendar; use Calendar; with Ada.Numerics.Float_Random; use Ada.Numerics.Float_Random; procedure Trybitops is -- verify functionality and benchmark bit operations B,C: Cell; Bl: constant Integer:= 1_000_005; T: Time; N: Natural; type Vec is array(Integer range <>) of Float; V: Vec:= (0.00001, 0.0001, 0.001, 0.01, 0.1, 0.2, 0.5, 0.7, 0.9, 0.99, 0.999, 0.9999, 0.99999); G: Generator; Trues: array(1..100) of Integer; Ti: Integer; begin B := Make_Bit_Vector(Bl,Bl); C := Make_Bit_Vector(Bl,Bl); for I in 1..Bl loop Set(B,Bl,False); end loop; T := Clock; N := Fast_First_Bit(B); loop if N=0 then exit; end if; N := Fast_Next_Bit(B,N); end loop; Put_Line(Ascii.Lf & "empty vector: " & "fast interator: " & Duration'Image(Clock-T)); Set(B,1,True); Set(B,6,True); Set(B,12,True); Set(B,15,True); Set(B,16,True); Set(B,31,True); Set(B,32,True); Set(B,33,True); Set(B,35,True); Set(B,255,True); Set(B,256,True); Set(B,257,True); Set(B,260,True); Set(B,Bl-100,True); Set(B,Bl-1,True); Set(B,Bl,True); T := Clock; Ti := 0; for I in 1..Bl loop if Elt(B,I) then Ti := Ti+1; Trues(Ti):=I; end if; end loop; Put_Line(Ascii.Lf & "loop of elt: " & Duration'Image(Clock-T)); for I in 1..Ti loop Put(Integer'Image(Trues(I))); end loop; T := Clock; Ti:= 0; N := Slow_First_Bit(B); Put(Integer'Image(N)); loop N := Slow_Next_Bit(B,N); if N=0 then exit; end if; Ti := Ti+1; Trues(Ti):= N; end loop; Put_Line(Ascii.Lf & "slow interator: " & Duration'Image(Clock-T)); for I in 1..Ti loop Put(Integer'Image(Trues(I))); end loop; T := Clock; Ti := 0; N := Fast_First_Bit(B); Put(Integer'Image(N)); loop N := Fast_Next_Bit(B,N); if N=0 then exit; end if; Ti := Ti+1; Trues(Ti):= N; end loop; Put_Line(Ascii.Lf & "fast interator: " & Duration'Image(Clock-T)); for I in 1..Ti loop Put(Integer'Image(Trues(I))); end loop; Reset(G); for J in V'Range loop for I in 1..Bl loop Set(B,I,Random(G)