-all: step0_repl
+all: step0_repl step1_read_print
step0_repl: step0_repl.adb
- gnatmake -f -g -o $@ $<
+ gnatmake -g -P$@
+
+step1_read_print: step1_read_print.adb types.ad[bs] reader.ad[bs] \
+ printer.ad[bs]
+ gnatmake -g -P$@
clean:
- rm -f b~* *.o *.ali step0_repl
+ rm -f obj/* step0_repl step1_read_print
--- /dev/null
+-------------------------------------------------------------------------------
+--
+-- Copyright (C) 1999 FlightSafety International and Ted Dennison
+--
+-- This file is part of the OpenToken package.
+--
+-- The OpenToken package 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 3, or (at your option)
+-- any later version. The OpenToken package 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 distributed with the OpenToken
+-- package; see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+--
+-- This software was originally developed by the following company, and was
+-- released as open-source software as a service to the community:
+--
+-- FlightSafety International Simulation Systems Division
+-- Broken Arrow, OK USA 918-259-4000
+--
+-------------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+-- This package implements a token recognizer for a token of a
+-- single characters from a given set.
+-----------------------------------------------------------------------------
+package body OpenToken.Recognizer.Single_Character_Set is
+
+ overriding procedure Clear (The_Token : in out Instance)
+ is begin
+ The_Token.State := First_Char;
+ end Clear;
+
+ overriding procedure Analyze
+ (The_Token : in out Instance;
+ Next_Char : in Character;
+ Verdict : out Analysis_Verdict)
+ is begin
+ case The_Token.State is
+ when First_Char =>
+ if Ada.Strings.Maps.Is_In (Element => Next_Char, Set => The_Token.Set) then
+ Verdict := Matches;
+ The_Token.State := Done;
+ else
+ Verdict := Failed;
+ The_Token.State := Done;
+ end if;
+ when Done =>
+ -- We shouldn't get called from here.
+ Verdict := Failed;
+ end case;
+ end Analyze;
+
+ ----------------------------------------------------------------------------
+ -- This procedure will be called to create a character set token
+ ----------------------------------------------------------------------------
+ function Get (Set : in Ada.Strings.Maps.Character_Set)
+ return Instance
+ is begin
+ return (Report => True,
+ State => First_Char,
+ Set => Set);
+ end Get;
+
+end OpenToken.Recognizer.Single_Character_Set;
--- /dev/null
+-------------------------------------------------------------------------------
+--
+-- Copyright (C) 1999 FlightSafety International and Ted Dennison
+--
+-- This file is part of the OpenToken package.
+--
+-- The OpenToken package 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 3, or (at your option)
+-- any later version. The OpenToken package 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 distributed with the OpenToken
+-- package; see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+--
+-- This software was originally developed by the following company, and was
+-- released as open-source software as a service to the community:
+--
+-- FlightSafety International Simulation Systems Division
+-- Broken Arrow, OK USA 918-259-4000
+--
+-------------------------------------------------------------------------------
+
+with Ada.Strings.Maps;
+with Ada.Characters.Latin_1;
+
+-----------------------------------------------------------------------------
+-- This package implements a token recognizer for a token of any
+-- number of characters from a given set. The most useful use of this
+-- facility in a typical application is locating strings of
+-- "whitespace"
+-----------------------------------------------------------------------------
+package OpenToken.Recognizer.Single_Character_Set is
+
+ type Instance is new OpenToken.Recognizer.Instance with private;
+
+ --------------------------------------------------------------------------
+ -- This procedure will be called to create a Character_Set token.
+ -- Set should be given a string containing all the characters that
+ -- can be the single character token. The Set may be created using the
+ -- operations in Ada.Strings.Maps.
+ --
+ --------------------------------------------------------------------------
+ function Get (Set : in Ada.Strings.Maps.Character_Set) return Instance;
+
+private
+
+
+ type State_ID is (First_Char, Done);
+
+ type Instance is new OpenToken.Recognizer.Instance with record
+
+ -- The finite state machine state
+ State : State_ID := First_Char;
+
+ Set : Ada.Strings.Maps.Character_Set;
+
+ end record;
+
+ overriding procedure Clear (The_Token : in out Instance);
+
+ overriding procedure Analyze
+ (The_Token : in out Instance;
+ Next_Char : in Character;
+ Verdict : out Analysis_Verdict);
+
+end OpenToken.Recognizer.Single_Character_Set;
--- /dev/null
+package body Printer is
+
+ function Pr_Str (M : Types.Mal_Type_Access) return String is
+ use Types;
+ begin
+ if M = null then
+ return "";
+ else
+ return To_String (M.all);
+ end if;
+ end Pr_Str;
+
+end Printer;
--- /dev/null
+with Types;
+
+package Printer is
+
+ function Pr_Str (M : Types.Mal_Type_Access) return String;
+
+end Printer;
--- /dev/null
+with Ada.IO_Exceptions;
+with Ada.Characters.Latin_1;
+with Ada.Strings.Maps.Constants;
+with Ada.Strings.Unbounded;
+with Ada.Text_IO;
+with Opentoken.Recognizer.Character_Set;
+with Opentoken.Recognizer.Identifier;
+with Opentoken.Recognizer.Integer;
+with Opentoken.Recognizer.Keyword;
+with Opentoken.Recognizer.Line_Comment;
+with Opentoken.Recognizer.Separator;
+with Opentoken.Recognizer.Single_Character_Set;
+with Opentoken.Recognizer.String;
+with OpenToken.Text_Feeder.String;
+with Opentoken.Token.Enumerated.Analyzer;
+
+package body Reader is
+
+ type Lexemes is (Int, Sym,
+ Nil, True_Tok, False_Tok, Exp_Tok,
+ Str, Atom,
+ Whitespace, Comment);
+
+ package Lisp_Tokens is new Opentoken.Token.Enumerated (Lexemes);
+ package Tokenizer is new Lisp_Tokens.Analyzer;
+
+ Exp_Recognizer : constant Tokenizer.Recognizable_Token :=
+ Tokenizer.Get(Opentoken.Recognizer.Separator.Get ("**"));
+
+ Nil_Recognizer : constant Tokenizer.Recognizable_Token :=
+ Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("nil"));
+
+ True_Recognizer : constant Tokenizer.Recognizable_Token :=
+ Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("true"));
+
+ False_Recognizer : constant Tokenizer.Recognizable_Token :=
+ Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("false"));
+
+ ID_Recognizer : constant Tokenizer.Recognizable_Token :=
+ Tokenizer.Get(Opentoken.Recognizer.Identifier.Get);
+
+ Int_Recognizer : constant Tokenizer.Recognizable_Token :=
+ Tokenizer.Get(Opentoken.Recognizer.Integer.Get);
+
+ String_Recognizer : constant Tokenizer.Recognizable_Token :=
+ Tokenizer.Get(Opentoken.Recognizer.String.Get);
+
+ -- Atom definition
+ Start_Chars : Ada.Strings.Maps.Character_Set :=
+ Ada.Strings.Maps.Constants.Letter_Set;
+
+ Body_Chars : Ada.Strings.Maps.Character_Set :=
+ Ada.Strings.Maps."or"
+ (Ada.Strings.Maps.Constants.Alphanumeric_Set,
+ Ada.Strings.Maps.To_Set ('-'));
+
+ Atom_Recognizer : constant Tokenizer.Recognizable_Token :=
+ Tokenizer.Get
+ (Opentoken.Recognizer.Identifier.Get (Start_Chars, Body_Chars));
+
+ Lisp_Syms : constant Ada.Strings.Maps.Character_Set :=
+ Ada.Strings.Maps.To_Set ("[]{}()'`~^@+-*/");
+
+ Sym_Recognizer : constant Tokenizer.Recognizable_Token :=
+ Tokenizer.Get (Opentoken.Recognizer.Single_Character_Set.Get (Lisp_Syms));
+
+ Lisp_Whitespace : constant Ada.Strings.Maps.Character_Set :=
+ Ada.Strings.Maps.To_Set (Ada.Characters.Latin_1.HT &
+ Ada.Characters.Latin_1.Space &
+ Ada.Characters.Latin_1.Comma);
+
+ Whitesp_Recognizer : constant Tokenizer.Recognizable_Token :=
+ Tokenizer.Get (Opentoken.Recognizer.Character_Set.Get (Lisp_Whitespace));
+
+ Comment_Recognizer : constant Tokenizer.Recognizable_Token :=
+ Tokenizer.Get(Opentoken.Recognizer.Line_Comment.Get (";"));
+
+ Syntax : constant Tokenizer.Syntax :=
+ (Int => Int_Recognizer,
+ Sym => Sym_Recognizer,
+ Nil => Nil_Recognizer,
+ True_Tok => True_Recognizer,
+ False_Tok => False_Recognizer,
+ Exp_Tok => Exp_Recognizer,
+ Str => String_Recognizer,
+ Atom => Atom_Recognizer,
+ Whitespace => Whitesp_Recognizer,
+ Comment => Comment_Recognizer --,
+ );
+
+ Input_Feeder : aliased OpenToken.Text_Feeder.String.Instance;
+
+ Analyzer : Tokenizer.Instance :=
+ Tokenizer.Initialize (Syntax, Input_Feeder'access);
+
+
+ function Get_Token_String return String is
+ begin
+ return Tokenizer.Lexeme (Analyzer);
+ end Get_Token_String;
+
+
+ function Get_Token_Char return Character is
+ S : String := Tokenizer.Lexeme (Analyzer);
+ begin
+ return S(S'First);
+ end Get_Token_Char;
+
+
+ function Get_Token return Types.Mal_Type_Access is
+ Res : Types.Mal_Type_Access;
+ begin
+ Tokenizer.Find_Next (Analyzer);
+ case Tokenizer.ID (Analyzer) is
+ when Int =>
+ Res := new Types.Mal_Type'
+ (Sym_Type => Types.Int,
+ Int_Val => Integer'Value (Get_Token_String));
+ when Sym =>
+ Res := new Types.Mal_Type'
+ (Sym_Type => Types.Sym, Symbol => Get_Token_Char);
+ when Nil =>
+ Res := new Types.Mal_Type'
+ (Sym_Type => Types.Atom,
+ The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
+ (Get_Token_String));
+ when True_Tok =>
+ Res := new Types.Mal_Type'
+ (Sym_Type => Types.Atom,
+ The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
+ (Get_Token_String));
+ when False_Tok =>
+ Res := new Types.Mal_Type'
+ (Sym_Type => Types.Atom,
+ The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
+ (Get_Token_String));
+ when Exp_Tok =>
+ Res := new Types.Mal_Type'
+ (Sym_Type => Types.Atom,
+ The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
+ (Get_Token_String));
+ when Str =>
+ Res := new Types.Mal_Type'
+ (Sym_Type => Types.Str,
+ The_String => Ada.Strings.Unbounded.To_Unbounded_String
+ (Get_Token_String));
+ when Atom =>
+ Res := new Types.Mal_Type'
+ (Sym_Type => Types.Atom,
+ The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
+ (Get_Token_String));
+ when Whitespace | Comment => null;
+ end case;
+ return Res;
+ end Get_Token;
+
+
+ -- Parsing
+ function Read_Form return Types.Mal_Type_Access;
+
+ function Read_List return Types.Mal_Type_Access is
+ use types;
+ List_MT, MTA : Types.Mal_Type_Access;
+ begin
+ List_MT := new Types.Mal_Type'
+ (Sym_Type => Types.List,
+ The_List => Types.Lists.Empty_List);
+ loop
+ MTA := Read_Form;
+ exit when MTA = null or else
+ MTA.all = (Sym_Type => Sym, Symbol => ')');
+ Types.Lists.Append (List_MT.The_List, MTA);
+ end loop;
+ return List_MT;
+ end Read_List;
+
+
+ function Read_Form return Types.Mal_Type_Access is
+ use Types;
+ MT : Types.Mal_Type_Access;
+ begin
+ MT := Get_Token;
+ if MT.all = (Sym_Type => Sym, Symbol => '(') then
+ return Read_List;
+ else
+ return MT;
+ end if;
+ end Read_Form;
+
+
+ function Read_Str (S : String) return Types.Mal_Type_Access is
+ begin
+ Analyzer.Reset;
+ Input_Feeder.Set (S);
+ return Read_Form;
+ exception
+ when OPENTOKEN.SYNTAX_ERROR =>
+ Ada.Text_IO.Put_Line
+ (Ada.Text_IO.Standard_Error,
+ "Lexical error at char " & Integer'Image (Analyzer.Line));
+ raise Ada.IO_Exceptions.End_Error;
+ end Read_Str;
+
+
+end Reader;
--- /dev/null
+with Types;
+
+package Reader is
+
+ -- This is the Parser (returns an AST)
+ function Read_Str (S : String) return Types.Mal_Type_Access;
+ --function Read_Str return Types.Mal_Type_Access;
+
+end Reader;
--- /dev/null
+project Step0_Repl is
+
+ for Object_Dir use "obj";
+ for Exec_Dir use ".";
+ for Main use ("step0_repl.adb");
+
+end Step0_Repl;
--- /dev/null
+with Ada.Text_IO;
+with Ada.IO_Exceptions;
+with Printer;
+with Reader;
+with Types;
+
+procedure Step1_Read_Print is
+
+ function Read (Param : String) return Types.Mal_Type_Access is
+ --function Read return Types.Mal_Type_Access is
+ begin
+ return Reader.Read_Str (Param);
+ --return Reader.Read_Str;
+ end Read;
+
+ function Eval (Param : Types.Mal_Type_Access) return Types.Mal_Type_Access is
+ begin
+ return Param;
+ end Eval;
+
+ function Print (Param : Types.Mal_Type_Access) return String is
+ begin
+ return Printer.Pr_Str (Param);
+ end Print;
+
+ function Rep (Param : String) return String is
+ --function Rep return String is
+ AST : Types.Mal_Type_Access := Read (Param);
+ Eval_Str : Types.Mal_Type_Access := Eval (AST);
+ Print_Str : String := Print (Eval_Str);
+ begin
+ return Print_Str;
+ end Rep;
+
+ S : String (1..1024);
+ Last : Natural;
+
+begin
+
+ loop
+ Ada.Text_IO.Put ("user> ");
+ Ada.Text_IO.Get_Line (S, Last);
+ Ada.Text_IO.Put_Line (Rep (S(1..Last)));
+ end loop;
+
+exception
+ when Ada.IO_Exceptions.End_Error => null;
+ -- i.e. exit without textual output
+end Step1_Read_Print;
--- /dev/null
+with "opentoken";
+
+project Step1_Read_Print is
+
+ for Object_Dir use "obj";
+ for Exec_Dir use ".";
+ for Main use ("step1_read_print.adb");
+
+end Step1_Read_Print;
--- /dev/null
+with Ada.Characters.Latin_1;
+with Ada.Text_IO;
+
+package body Types is
+
+ package ACL renames Ada.Characters.Latin_1;
+
+ function To_String (T : Mal_Type) return String is
+ use Ada.Strings.Unbounded;
+ begin
+ case T.Sym_Type is
+ when Int =>
+ declare
+ Res : String := Integer'Image (T.Int_Val);
+ begin
+ if Res (1) = ' ' then
+ return Res (2..Res'Last);
+ else
+ return "int> " & Res;
+ end if;
+ end;
+ when List =>
+
+ declare
+ UBS : Unbounded_String := Null_Unbounded_String;
+ C : Lists.Cursor;
+ use type Lists.Cursor;
+ First_Pass : Boolean := True;
+ begin
+ if Lists.Is_Empty (T.The_List) then
+ return "()";
+ end if;
+ C := Lists.First (T.The_List);
+ loop
+ if First_Pass then
+ First_Pass := False;
+ else
+ Append (UBS, " ");
+ end if;
+ UBStrings.Append (UBS, To_String (Lists.Element (C).all));
+ exit when C = Lists.Last (T.The_List);
+ C := Lists.Next (C);
+ end loop;
+ return "(" & To_String (UBS) & ")";
+ end;
+ when Sym =>
+ return "" & T.Symbol;
+ when Str =>
+ -- The_String includes the quotation marks.
+ return To_String (T.The_String);
+ when Atom =>
+ return To_String (T.The_Atom);
+ when EOLine =>
+ return "";
+ end case;
+ end To_String;
+
+end Types;
--- /dev/null
+with Ada.Containers.Doubly_Linked_Lists;
+with Ada.Strings.Unbounded;
+
+package Types is
+
+ package UBStrings renames Ada.Strings.Unbounded;
+
+ type Mal_Type;
+
+ type Mal_Type_Access is access all Mal_Type;
+
+ package Lists is
+ new Ada.Containers.Doubly_Linked_Lists
+ (Element_Type => Mal_Type_Access,
+ "=" => "=");
+
+ type Sym_Types is (Int, List, Sym, Str, Atom, EOLine);
+
+ type Mal_Type (Sym_Type : Sym_Types) is record
+ case Sym_Type is
+ when Int => Int_Val : Integer;
+ when List => The_List : Lists.List;
+ when Sym => Symbol : Character;
+ when Str => The_String : Ada.Strings.Unbounded.Unbounded_String;
+ when Atom => The_Atom : Ada.Strings.Unbounded.Unbounded_String;
+ when EOLine => null;
+ end case;
+ end record;
+
+ function To_String (T : Mal_Type) return String;
+
+end Types;
HCoop / jackhill / mal.git / commitdiff