ada.2/stepa_mal.adb

   1 with Ada.Command_Line;
   2 with Ada.Containers.Vectors;
   3 with Ada.Environment_Variables;
   4 with Ada.Strings.Unbounded;
   5 with Ada.Text_IO.Unbounded_IO;
   6
   7 with Core;
   8 with Envs;
   9 with Err;
  10 with Eval_Cb;
  11 with Garbage_Collected;
  12 with Printer;
  13 with Reader;
  14 with Readline;
  15 with Types.Builtins;
  16 with Types.Fns;
  17 with Types.Mal;
  18 with Types.Maps;
  19 with Types.Sequences;
  20 with Types.Symbols.Names;
  21
  22 procedure StepA_Mal is
  23
  24    Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
  25
  26    use Types;
  27    use type Mal.T;
  28    package ACL renames Ada.Command_Line;
  29    package ASU renames Ada.Strings.Unbounded;
  30
  31    function Read return Mal.T_Array with Inline;
  32
  33    function Eval (Ast0 : in Mal.T;
  34                   Env0 : in Envs.Ptr) return Mal.T;
  35    function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
  36    --  The built-in variant needs to see the Repl variable.
  37
  38    function Quasiquote (Ast : in Mal.T;
  39                         Env : in Envs.Ptr) return Mal.T;
  40    --  Mergeing quote and quasiquote into eval with a flag triggering
  41    --  a different behaviour as done for macros in step8 would improve
  42    --  the performances significantly, but Kanaka finds that it breaks
  43    --  too much the step structure shared by all implementations.
  44
  45    procedure Print (Ast : in Mal.T) with Inline;
  46
  47    procedure Rep (Env : in Envs.Ptr) with Inline;
  48
  49    function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
  50
  51    procedure Exec (Script : in String;
  52                    Env    : in Envs.Ptr) with Inline;
  53    --  Read the script, eval its elements, but ignore the result.
  54
  55    ----------------------------------------------------------------------
  56
  57    function Eval (Ast0 : in Mal.T;
  58                   Env0 : in Envs.Ptr) return Mal.T
  59    is
  60       use type Symbols.Ptr;
  61       --  Use local variables, that can be rewritten when tail call
  62       --  optimization goes to <<Restart>>.
  63       Ast            : Mal.T    := Ast0;
  64       Env            : Envs.Ptr := Env0;
  65       Macroexpanding : Boolean  := False;
  66       First          : Mal.T;
  67    begin
  68       <<Restart>>
  69       if Dbgeval then
  70          Ada.Text_IO.New_Line;
  71          Ada.Text_IO.Put ("EVAL: ");
  72          Print (Ast);
  73          Envs.Dump_Stack (Env.all);
  74       end if;
  75
  76       case Ast.Kind is
  77       when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
  78         | Kind_Macro | Kind_Function =>
  79          return Ast;
  80       when Kind_Symbol =>
  81          return Env.all.Get (Ast.Symbol);
  82       when Kind_Map =>
  83          return Eval_Map_Elts (Ast.Map.all, Env);
  84       when Kind_Vector =>
  85          declare
  86             Len  : constant Natural := Ast.Sequence.all.Length;
  87             List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
  88          begin
  89             for I in 1 .. Len loop
  90                List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
  91             end loop;
  92             return (Kind_Vector, List);
  93          end;
  94       when Kind_List =>
  95          null;
  96       end case;
  97
  98       --  Ast is a list.
  99       if Ast.Sequence.all.Length = 0 then
 100          return Ast;
 101       end if;
 102       First := Ast.Sequence.all (1);
 103
 104       --  Special forms
 105       --  Ast is a non-empty list, First is its first element.
 106       case First.Kind is
 107       when Kind_Symbol =>
 108          if First.Symbol = Symbols.Names.Def then
 109             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 110             Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
 111                        "parameter 1 must be a symbol");
 112             return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
 113                Env.all.Set (Ast.Sequence.all (2).Symbol, R);
 114             end return;
 115          elsif First.Symbol = Symbols.Names.Defmacro then
 116             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 117             Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
 118                        "parameter 1 must be a symbol");
 119             declare
 120                F : constant Mal.T  := Eval (Ast.Sequence.all (3), Env);
 121             begin
 122                Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
 123                return R : constant Mal.T := F.Fn.all.New_Macro do
 124                   Env.all.Set (Ast.Sequence.all (2).Symbol, R);
 125                end return;
 126             end;
 127          --  do is a built-in function, shortening this test cascade.
 128          elsif First.Symbol = Symbols.Names.Fn then
 129             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 130             Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
 131                        "parameter 1 must be a sequence");
 132             return Fns.New_Function
 133               (Params => Ast.Sequence.all (2).Sequence.all,
 134                Ast    => Ast.Sequence.all (3),
 135                Env    => Env);
 136          elsif First.Symbol = Symbols.Names.Mal_If then
 137             Err.Check (Ast.Sequence.all.Length in 3 .. 4,
 138                        "expected 2 or 3 parameters");
 139             declare
 140                Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
 141             begin
 142                if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
 143                   Ast := Ast.Sequence.all (3);
 144                   goto Restart;
 145                elsif Ast.Sequence.all.Length = 3 then
 146                   return Mal.Nil;
 147                else
 148                   Ast := Ast.Sequence.all (4);
 149                   goto Restart;
 150                end if;
 151             end;
 152          elsif First.Symbol = Symbols.Names.Let then
 153             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 154             Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
 155                        "parameter 1 must be a sequence");
 156             declare
 157                Bindings : constant Mal.Sequence_Ptr
 158                  := Ast.Sequence.all (2).Sequence;
 159             begin
 160                Err.Check (Bindings.all.Length mod 2 = 0,
 161                           "parameter 1 must have an even length");
 162                Env := Envs.New_Env (Outer => Env);
 163                for I in 1 .. Bindings.all.Length / 2 loop
 164                   Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
 165                              "binding keys must be symbols");
 166                   Env.all.Set (Bindings.all (2 * I - 1).Symbol,
 167                                Eval (Bindings.all (2 * I), Env));
 168                end loop;
 169                Ast := Ast.Sequence.all (3);
 170                goto Restart;
 171             end;
 172          elsif First.Symbol = Symbols.Names.Macroexpand then
 173             Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
 174             Macroexpanding := True;
 175             Ast := Ast.Sequence.all (2);
 176             goto Restart;
 177          elsif First.Symbol = Symbols.Names.Quasiquote then
 178             Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
 179             return Quasiquote (Ast.Sequence.all (2), Env);
 180          elsif First.Symbol = Symbols.Names.Quote then
 181             Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
 182             return Ast.Sequence.all (2);
 183          elsif First.Symbol = Symbols.Names.Try then
 184             if Ast.Sequence.all.Length = 2 then
 185                Ast := Ast.Sequence.all (2);
 186                goto Restart;
 187             end if;
 188             Err.Check (Ast.Sequence.all.Length = 3,
 189                        "expected 1 or 2 parameters");
 190             Err.Check (Ast.Sequence.all (3).Kind = Kind_List,
 191                        "parameter 2 must be a list");
 192             declare
 193                A3 : constant Mal.Sequence_Ptr := Ast.Sequence.all (3).Sequence;
 194             begin
 195                Err.Check (A3.all.Length = 3,
 196                           "length of parameter 2 must be 3");
 197                Err.Check (A3.all (1) = (Kind_Symbol, Symbols.Names.Catch),
 198                           "parameter 3 must start with 'catch*'");
 199                Err.Check (A3.all (2).Kind = Kind_Symbol,
 200                           "a symbol must follow catch*");
 201                begin
 202                   return Eval (Ast.Sequence.all (2), Env);
 203                exception
 204                   when Err.Error =>
 205                      null;
 206                end;
 207                Env := Envs.New_Env (Outer => Env);
 208                Env.all.Set (A3.all (2).Symbol, Err.Data);
 209                Ast := A3.all (3);
 210                goto Restart;
 211             end;
 212          else
 213             --  Equivalent to First := Eval (First, Env)
 214             --  except that we already know enough to spare a recursive call.
 215             First := Env.all.Get (First.Symbol);
 216          end if;
 217       when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
 218         | Kind_Macro | Kind_Function =>
 219          --  Equivalent to First := Eval (First, Env)
 220          --  except that we already know enough to spare a recursive call.
 221          null;
 222       when Kind_Sequence | Kind_Map =>
 223          --  Lists are definitely worth a recursion, and the two other
 224          --  cases should be rare (they will report an error later).
 225          First := Eval (First, Env);
 226       end case;
 227
 228       --  Apply phase.
 229       --  Ast is a non-empty list,
 230       --  First is its non-special evaluated first element.
 231       case First.Kind is
 232          when Kind_Builtin =>
 233             declare
 234                Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
 235             begin
 236                for I in Args'Range loop
 237                   Args (I) := Eval (Ast.Sequence.all (I), Env);
 238                end loop;
 239                return First.Builtin.all (Args);
 240             end;
 241          when Kind_Builtin_With_Meta =>
 242             declare
 243                Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
 244             begin
 245                for I in Args'Range loop
 246                   Args (I) := Eval (Ast.Sequence.all (I), Env);
 247                end loop;
 248                return First.Builtin_With_Meta.all.Builtin.all (Args);
 249             end;
 250          when Kind_Fn =>
 251             declare
 252                Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
 253             begin
 254                for I in Args'Range loop
 255                   Args (I) := Eval (Ast.Sequence.all (I), Env);
 256                end loop;
 257                Env := Envs.New_Env (Outer => First.Fn.all.Env,
 258                                     Binds => First.Fn.all.Params,
 259                                     Exprs => Args);
 260                Ast := First.Fn.all.Ast;
 261                goto Restart;
 262             end;
 263          when Kind_Macro =>
 264             declare
 265                Args : constant Mal.T_Array
 266                  := Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
 267             begin
 268                if Macroexpanding then
 269                   --  Evaluate the macro with tail call optimization.
 270                   Env := Envs.New_Env (Outer => Env,
 271                                        Binds => First.Fn.all.Params,
 272                                        Exprs => Args);
 273                   Ast := First.Fn.all.Ast;
 274                   goto Restart;
 275                else
 276                   --  Evaluate the macro normally.
 277                   Ast := Eval (First.Fn.all.Ast,
 278                                Envs.New_Env (Outer => Env,
 279                                              Binds => First.Fn.all.Params,
 280                                              Exprs => Args));
 281                   --  Then evaluate the result with TCO.
 282                   goto Restart;
 283                end if;
 284             end;
 285          when others =>
 286             Err.Raise_With ("first element must be a function or macro");
 287       end case;
 288    exception
 289       when Err.Error =>
 290          if Macroexpanding then
 291             Err.Add_Trace_Line ("macroexpand", Ast);
 292          else
 293             Err.Add_Trace_Line ("eval", Ast);
 294          end if;
 295          raise;
 296    end Eval;
 297
 298    procedure Exec (Script : in String;
 299                    Env    : in Envs.Ptr)
 300    is
 301       Result : Mal.T;
 302    begin
 303       for Expression of Reader.Read_Str (Script) loop
 304          Result := Eval (Expression, Env);
 305       end loop;
 306       pragma Unreferenced (Result);
 307    end Exec;
 308
 309    procedure Print (Ast : in Mal.T) is
 310    begin
 311       Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
 312    end Print;
 313
 314    function Quasiquote (Ast : in Mal.T;
 315                         Env : in Envs.Ptr) return Mal.T
 316    is
 317
 318       function Quasiquote_List (List : in Sequences.Instance) return Mal.T
 319         with Inline;
 320       --  Handle vectors and lists not starting with unquote.
 321
 322       function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
 323          package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
 324          Vector   : Vectors.Vector; --  buffer for concatenation
 325          Sequence : Mal.Sequence_Ptr;
 326          Tmp      : Mal.T;
 327       begin
 328          for I in 1 .. List.Length loop
 329             if List (I).Kind in Kind_List
 330               and then 0 < List (I).Sequence.all.Length
 331               and then List (I).Sequence.all (1)
 332                 = (Kind_Symbol, Symbols.Names.Splice_Unquote)
 333             then
 334                Err.Check (List (I).Sequence.all.Length = 2,
 335                           "splice-unquote expects 1 parameter");
 336                Tmp := Eval (List (I).Sequence.all (2), Env);
 337                Err.Check (Tmp.Kind = Kind_List,
 338                           "splice_unquote expects a list");
 339                for I in 1 .. Tmp.Sequence.all.Length loop
 340                   Vector.Append (Tmp.Sequence.all (I));
 341                end loop;
 342             else
 343                Vector.Append (Quasiquote (List (I), Env));
 344             end if;
 345          end loop;
 346          --  Now that we know the number of elements, convert to a list.
 347          Sequence := Sequences.Constructor (Natural (Vector.Length));
 348          for I in 1 .. Natural (Vector.Length) loop
 349             Sequence.Replace_Element (I, Vector (I));
 350          end loop;
 351          return (Kind_List, Sequence);
 352       end Quasiquote_List;
 353
 354    begin                                --  Quasiquote
 355       case Ast.Kind is
 356          when Kind_Vector =>
 357             --  When the test is updated, replace Kind_List with Kind_Vector.
 358             return Quasiquote_List (Ast.Sequence.all);
 359          when Kind_List =>
 360             if 0 < Ast.Sequence.all.Length
 361               and then Ast.Sequence.all (1) = (Kind_Symbol,
 362                                                Symbols.Names.Unquote)
 363             then
 364                Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
 365                return Eval (Ast.Sequence.all (2), Env);
 366             else
 367                return Quasiquote_List (Ast.Sequence.all);
 368             end if;
 369          when others =>
 370             return Ast;
 371       end case;
 372    exception
 373       when Err.Error =>
 374          Err.Add_Trace_Line ("quasiquote", Ast);
 375          raise;
 376    end Quasiquote;
 377
 378    function Read return Mal.T_Array
 379    is (Reader.Read_Str (Readline.Input ("user> ")));
 380
 381    procedure Rep (Env : in Envs.Ptr) is
 382    begin
 383       for Expression of Read loop
 384          Print (Eval (Expression, Env));
 385       end loop;
 386    end Rep;
 387
 388    ----------------------------------------------------------------------
 389
 390    Startup : constant String
 391      := "(def! not (fn* (a) (if a false true)))"
 392      & "(def! load-file (fn* (f)"
 393      & "  (eval (read-string (str ""(do "" (slurp f) "")"")))))"
 394      & "(defmacro! cond (fn* (& xs)"
 395      & "  (if (> (count xs) 0)"
 396      & "    (list 'if (first xs)"
 397      & "      (if (> (count xs) 1) (nth xs 1)"
 398      & "        (throw ""odd number of forms to cond""))"
 399      & "      (cons 'cond (rest (rest xs)))))))"
 400      & "(def! *gensym-counter* (atom 0))"
 401      & "(def! gensym (fn* [] "
 402      & "  (symbol (str ""G__"" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))"
 403      & "(defmacro! or (fn* (& xs)"
 404      & "  (if (empty? xs) nil"
 405      & "  (if (= 1 (count xs)) (first xs)"
 406      & "  (let* (condvar (gensym))"
 407      & "    `(let* (~condvar ~(first xs))"
 408      & "      (if ~condvar ~condvar (or ~@(rest xs)))))))))"
 409      & "(def! *host-language* ""ada.2"")";
 410    Repl : constant Envs.Ptr := Envs.New_Env;
 411    function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
 412    begin
 413       Err.Check (Args'Length = 1, "expected 1 parameter");
 414       return Eval_Cb.Cb.all (Args (Args'First), Repl);
 415    end Eval_Builtin;
 416    Script : constant Boolean := 0 < ACL.Argument_Count;
 417    Argv   : Mal.Sequence_Ptr;
 418 begin
 419    --  Show the Eval function to other packages.
 420    Eval_Cb.Cb := Eval'Unrestricted_Access;
 421    --  Add Core functions into the top environment.
 422    Core.NS_Add_To_Repl (Repl);
 423    Repl.all.Set (Symbols.Constructor ("eval"),
 424                  (Kind_Builtin, Eval_Builtin'Unrestricted_Access));
 425    --  Native startup procedure.
 426    Exec (Startup, Repl);
 427    --  Define ARGV from command line arguments.
 428    if Script then
 429       Argv := Sequences.Constructor (ACL.Argument_Count - 1);
 430       for I in 2 .. ACL.Argument_Count loop
 431          Argv.all.Replace_Element
 432            (I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
 433       end loop;
 434    else
 435       Argv := Sequences.Constructor (0);
 436    end if;
 437    Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
 438    --  Execute user commands.
 439    if Script then
 440       Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
 441    else
 442       Exec ("(println (str ""Mal ["" *host-language* ""]""))", Repl);
 443       loop
 444          begin
 445             Rep (Repl);
 446          exception
 447             when Readline.End_Of_File =>
 448                exit;
 449             when Err.Error =>
 450                Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
 451          end;
 452          --  Other exceptions are really unexpected.
 453
 454          --  Collect garbage.
 455          Err.Data := Mal.Nil;
 456          Repl.all.Keep;
 457          Garbage_Collected.Clean;
 458       end loop;
 459       Ada.Text_IO.New_Line;
 460    end if;
 461
 462    --  If assertions are enabled, check deallocations.
 463    pragma Debug (Garbage_Collected.Clean);
 464    Garbage_Collected.Check_Allocations;
 465    Symbols.Check_Allocations;
 466 end StepA_Mal;