From mboxrd@z Thu Jan 1 00:00:00 1970 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on polar.synack.me X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham autolearn_force=no version=3.4.4 X-Google-Thread: 103376,24d7acf9b853aac8 X-Google-NewGroupId: yes X-Google-Attributes: gida07f3367d7,domainid0,public,usenet X-Google-Language: ENGLISH,ASCII-7-bit Path: g2news1.google.com!news3.google.com!feeder3.cambriumusenet.nl!feed.tweaknews.nl!87.79.20.105.MISMATCH!news.netcologne.de!ramfeed1.netcologne.de!newsfeed.arcor.de!newsspool2.arcor-online.net!news.arcor.de.POSTED!not-for-mail Date: Sun, 01 Aug 2010 22:44:24 +0200 From: Georg Bauhaus User-Agent: Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10.6; en-US; rv:1.9.2.7) Gecko/20100713 Thunderbird/3.1.1 MIME-Version: 1.0 Newsgroups: comp.lang.ada Subject: Re: S-expression I/O in Ada References: <547afa6b-731e-475f-a7f2-eaefefb25861@k8g2000prh.googlegroups.com> <4c55da3e$0$6889$9b4e6d93@newsspool2.arcor-online.net> In-Reply-To: <4c55da3e$0$6889$9b4e6d93@newsspool2.arcor-online.net> Content-Type: text/plain; charset=ISO-8859-1; format=flowed Content-Transfer-Encoding: 7bit Message-ID: <4c55dca9$0$6889$9b4e6d93@newsspool2.arcor-online.net> Organization: Arcor NNTP-Posting-Date: 01 Aug 2010 22:44:25 CEST NNTP-Posting-Host: a8c56fe8.newsspool2.arcor-online.net X-Trace: DXC=k>>akgZV?GFFJ3]dH>I?oEA9EHlD;3YcB4Fo<]lROoRA8kFejVHhSJ9@R8nAF@meK139Zn\PJ X-Complaints-To: usenet-abuse@arcor.de Xref: g2news1.google.com comp.lang.ada:12790 Date: 2010-08-01T22:44:25+02:00 List-Id: (The same again, if you can be bothered, untabified and after ada-remove-trailing-spaces.) with Ada.Finalization; use Ada; package S_Expressions is pragma Preelaborate (S_Expressions); -- -- Provide definitions typical of Lisp (ad hoc; no Lisp expert -- here.) -- type EQ_Type is limited Interface; function EQ (Left, Right : EQ_Type) return Boolean is abstract; -- objects of the same kind may be compared in specific ways function "=" (Left, Right: EQ_Type'Class) return Boolean; -- General comparison operation for each object in the system, -- dispatches to EQ if Left'Tag = Right'Tag. subtype Defined is Finalization.Limited_Controlled; -- Every object in the system is unique and has no "=", -- since all objects are limited. Also adds hooks for -- garbage collection. -- -- Root of everything not a list -- type Atom is abstract new Defined and EQ_Type with private; -- Symbols, Numbers, Character strings, ... function EQ (Left, Right : Atom) return Boolean is abstract; -- Kinds of atoms, with construction functions: type Symbol(<>) is new Atom with private; function Make_Symbol (Name : String) return Symbol; type Numeric is range 0 .. 666; -- or something better suited type Number(<>) is new Atom with private; function Make_Number (Initial : Numeric) return Number; -- -- Lists, construction and access to elements: -- type List is new Defined and EQ_Type with private; Nil: constant Symbol; function Cons (Car, Cdr : Defined'Class) return List; type Ptr is access constant Defined'Class; -- read-only access to elements of lists function Car (L : List) return Ptr; function Cdr (L : List) return Ptr; private -- -- Equality functions of all types that need to implement EQ_Type -- function EQ (Left, Right : Symbol) return Boolean; function EQ (Left, Right : Number) return Boolean; function EQ (Left, Right : List) return Boolean; -- ... type Atom is abstract new Defined and EQ_Type with null record; type Symbol_Chars is access constant String; type Symbol(Name : Symbol_Chars) is new Atom with null record; Nil_Chars : aliased constant String := ""; -- (static) Nil: constant Symbol := Symbol'(Atom with Name => Nil_Chars'Access); type Number(Value : Numeric) is new Atom with null record; type List is new Defined and EQ_Type with record Info : Ptr; Next : Ptr; end record; end S_Expressions; with S_Expressions; use S_Expressions; procedure S_Test is A: Symbol := Make_Symbol("Foo"); B: Symbol := Make_Symbol("Foo"); M: Number := Make_Number(42); N: Number := Make_Number(42); S : List := Cons(Make_Number(1), Cons(Make_Number(2), Cons(Make_Number(3), Nil))); Sx : List := Cons(Make_Number(1), Cons(Make_Number(2), Cons(Make_Number(3), Nil))); begin if A /= B then -- same name!! raise Program_Error; end if; if M /= N then -- same value!! raise Program_Error; end if; if A = N then -- different kinds of atoms!! raise Program_Error; end if; if S = Sx then -- different lists (even though same values) raise Program_Error; end if; if S /= S then raise Program_Error; end if; declare Cadr : constant Ptr := Car (List( Cdr (S).all)); begin if Number(Cadr.all) /= Make_Number(2) then -- same value!! raise Program_Error; end if; end; end S_Test; with Ada.Tags; with System; package body S_Expressions is -- Comparison function EQ (Left, Right : Symbol) return Boolean is begin return Left.Name.all = Right.Name.all; end EQ; function EQ (Left, Right : Number) return Boolean is begin return Left.Value = Right.Value; end EQ; function EQ (Left, Right : List) return Boolean is use type System.Address; begin return Left'Address = Right'Address; end EQ; function "=" (Left, Right: EQ_Type'Class) return Boolean is use type Ada.Tags.Tag; begin if Left'Tag /= Right'Tag then return False; else return EQ (Left, Right); end if; end "="; -- Making atoms function Make_Number (Initial : Numeric) return Number is begin return Number'(Defined with Value => Initial); end Make_Number; function Make_Symbol (Name : String) return Symbol is begin return Symbol'(Defined with Name => new String'(Name)); end Make_Symbol; -- Lists function Cons (Car, Cdr : Defined'Class) return List is begin return List'(Defined with Info => Car'Unchecked_Access, Next => Cdr'Unchecked_Access); end Cons; function Car (L : List) return Ptr is begin return L.Info; end Car; function Cdr (L : List) return Ptr is begin return L.Next; end Cdr; end S_Expressions;