impls/ada/stepa_mal.adb

   1 with Ada.Command_Line;
   2 with Ada.Exceptions;
   3 with Ada.Text_IO;
   4 with Core;
   5 with Envs;
   6 with Eval_Callback;
   7 with Printer;
   8 with Reader;
   9 with Smart_Pointers;
  10 with Types;
  11
  12 procedure StepA_Mal is
  13
  14    use Types;
  15
  16    function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle)
  17    return Types.Mal_Handle;
  18
  19    Debug : Boolean := False;
  20
  21
  22    function Read (Param : String) return Types.Mal_Handle is
  23    begin
  24       return Reader.Read_Str (Param);
  25    end Read;
  26
  27
  28    function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle)
  29                    return Mal_Handle is
  30       Name, Fn_Body, Res : Mal_Handle;
  31    begin
  32       Name := Car (Args);
  33       pragma Assert (Deref (Name).Sym_Type = Sym,
  34                      "Def_Fn: expected atom as name");
  35       Fn_Body := Nth (Args, 1);
  36       Res := Eval (Fn_Body, Env);
  37       Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res);
  38       return Res;
  39    end Def_Fn;
  40
  41
  42    function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle)
  43                    return Mal_Handle is
  44       Name, Fn_Body, Res : Mal_Handle;
  45       Lambda_P : Lambda_Ptr;
  46    begin
  47       Name := Car (Args);
  48       pragma Assert (Deref (Name).Sym_Type = Sym,
  49                      "Def_Macro: expected atom as name");
  50       Fn_Body := Car (Deref_List (Cdr (Args)).all);
  51       Res := Eval (Fn_Body, Env);
  52       Lambda_P := Deref_Lambda (Res);
  53       Lambda_P.Set_Is_Macro (True);
  54       Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res);
  55       return Res;
  56    end Def_Macro;
  57
  58
  59    function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle)
  60    return Mal_Handle is
  61       Res : Mal_Handle;
  62       E : Envs.Env_Handle;
  63       LMT : List_Mal_Type;
  64       LP : Lambda_Ptr;
  65    begin
  66
  67       Res := Ast;
  68       E := Env;
  69
  70       loop
  71
  72          if Deref (Res).Sym_Type /= List then
  73             exit;
  74          end if;
  75
  76          LMT := Deref_List (Res).all;
  77
  78          -- Get the macro in the list from the env
  79          -- or return null if not applicable.
  80          LP := Get_Macro (Res, E);
  81
  82       exit when LP = null or else not LP.Get_Is_Macro;
  83
  84           declare
  85              Fn_List : Mal_Handle := Cdr (LMT);
  86              Params : List_Mal_Type;
  87           begin
  88              E := Envs.New_Env (E);
  89
  90              Params := Deref_List (LP.Get_Params).all;
  91              if Envs.Bind (E, Params, Deref_List (Fn_List).all) then
  92
  93                 Res := Eval (LP.Get_Expr, E);
  94
  95              end if;
  96
  97           end;
  98
  99       end loop;
 100
 101       return Res;
 102
 103    end Macro_Expand;
 104
 105
 106    function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
 107       Res : Boolean;
 108    begin
 109       case Deref (MH).Sym_Type is
 110          when Bool =>
 111             Res := Deref_Bool (MH).Get_Bool;
 112          when Nil =>
 113             return False;
 114 --         when List =>
 115 --            declare
 116 --               L : List_Mal_Type;
 117 --            begin
 118 --               L := Deref_List (MH).all;
 119 --               Res := not Is_Null (L);
 120 --            end;
 121          when others => -- Everything else
 122             Res := True;
 123       end case;
 124       return Res;
 125    end Eval_As_Boolean;
 126
 127
 128    function Eval_Ast
 129      (Ast : Mal_Handle; Env : Envs.Env_Handle)
 130      return Mal_Handle is
 131
 132       function Call_Eval (A : Mal_Handle) return Mal_Handle is
 133       begin
 134          return Eval (A, Env);
 135       end Call_Eval;
 136
 137    begin
 138
 139       case Deref (Ast).Sym_Type is
 140
 141          when Sym =>
 142
 143             declare
 144                Sym : Mal_String := Deref_Sym (Ast).Get_Sym;
 145             begin
 146                -- if keyword, return it. Otherwise look it up in the environment.
 147                if Sym(1) = ':' then
 148                   return Ast;
 149                else
 150                   return Envs.Get (Env, Sym);
 151                end if;
 152             exception
 153                when Envs.Not_Found =>
 154                   raise Envs.Not_Found with ("'" &  Sym & "' not found");
 155             end;
 156
 157          when List =>
 158
 159             return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
 160
 161          when others => return Ast;
 162
 163       end case;
 164
 165    end Eval_Ast;
 166
 167
 168    function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is
 169       Res, First_Elem, FE_0 : Mal_Handle;
 170       L : List_Ptr;
 171       D_Ptr, Ast_P : List_Class_Ptr;
 172    begin
 173
 174       if Debug then
 175          Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String);
 176       end if;
 177
 178       -- Create a New List for the result...
 179       Res := New_List_Mal_Type (List_List);
 180       L := Deref_List (Res);
 181
 182       -- This is the equivalent of Is_Pair
 183       if Deref (Param).Sym_Type /= List or else
 184          Is_Null (Deref_List_Class (Param).all) then
 185
 186          -- return a new list containing: a symbol named "quote" and ast.
 187          L.Append (New_Symbol_Mal_Type ("quote"));
 188          L.Append (Param);
 189          return Res;
 190
 191       end if;
 192
 193       -- Ast is a non-empty list at this point.
 194
 195       Ast_P := Deref_List_Class (Param);
 196
 197       First_Elem := Car (Ast_P.all);
 198
 199       -- if the first element of ast is a symbol named "unquote":
 200       if Deref (First_Elem).Sym_Type = Sym and then
 201          Deref_Sym (First_Elem).Get_Sym = "unquote" then
 202
 203          -- return the second element of ast.`
 204          D_Ptr := Deref_List_Class (Cdr (Ast_P.all));
 205          return Car (D_Ptr.all);
 206
 207       end if;
 208
 209       -- if the first element of first element of `ast` (`ast[0][0]`)
 210       -- is a symbol named "splice-unquote"
 211       if Deref (First_Elem).Sym_Type = List and then
 212          not Is_Null (Deref_List_Class (First_Elem).all) then
 213
 214          D_Ptr := Deref_List_Class (First_Elem);
 215          FE_0 := Car (D_Ptr.all);
 216
 217          if Deref (FE_0).Sym_Type = Sym and then
 218             Deref_Sym (FE_0).Get_Sym = "splice-unquote" then
 219
 220             -- return a new list containing: a symbol named "concat",
 221             L.Append (New_Symbol_Mal_Type ("concat"));
 222
 223             -- the second element of first element of ast (ast[0][1]),
 224             D_Ptr := Deref_List_Class (Cdr (D_Ptr.all));
 225             L.Append (Car (D_Ptr.all));
 226
 227             -- and the result of calling quasiquote with
 228             -- the second through last element of ast.
 229             L.Append (Quasi_Quote_Processing (Cdr (Ast_P.all)));
 230
 231             return Res;
 232
 233          end if;
 234
 235       end if;
 236
 237       -- otherwise: return a new list containing: a symbol named "cons",
 238       L.Append (New_Symbol_Mal_Type ("cons"));
 239
 240       -- the result of calling quasiquote on first element of ast (ast[0]),
 241       L.Append (Quasi_Quote_Processing (Car (Ast_P.all)));
 242
 243       -- and result of calling quasiquote with the second through last element of ast.
 244       L.Append (Quasi_Quote_Processing (Cdr (Ast_P.all)));
 245
 246       return Res;
 247
 248    end Quasi_Quote_Processing;
 249
 250
 251    function Catch_Processing
 252               (Try_Line : Mal_Handle;
 253                ExStr : Mal_Handle;
 254                Env : Envs.Env_Handle)
 255    return Mal_Handle is
 256
 257       L, CL, CL2, CL3 : List_Mal_Type;
 258       C : Mal_Handle;
 259       New_Env : Envs.Env_Handle;
 260
 261    begin
 262
 263       L := Deref_List (Try_Line).all;
 264       C := Car (L);
 265       -- CL is the list with the catch in.
 266       CL := Deref_List (C).all;
 267
 268       CL2 := Deref_List (Cdr (CL)).all;
 269       New_Env := Envs.New_Env (Env);
 270       Envs.Set (New_Env, Deref_Sym (Car (CL2)).Get_Sym, ExStr);
 271
 272       CL3 := Deref_List (Cdr (CL2)).all;
 273       return Eval (Car (CL3), New_Env);
 274    end Catch_Processing;
 275
 276
 277    function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
 278                  return Mal_Handle is
 279       Param : Mal_Handle;
 280       Env : Envs.Env_Handle;
 281       First_Param, Rest_Params : Mal_Handle;
 282       Rest_List, Param_List : List_Mal_Type;
 283    begin
 284
 285       Param := AParam;
 286       Env := AnEnv;
 287
 288       <<Tail_Call_Opt>>
 289
 290       if Debug then
 291          Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
 292       end if;
 293
 294       Param := Macro_Expand (Param, Env);
 295
 296       if Debug then
 297          Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String);
 298       end if;
 299
 300       if Deref (Param).Sym_Type = List and then
 301         Deref_List (Param).Get_List_Type = List_List then
 302
 303          Param_List := Deref_List (Param).all;
 304
 305          -- Deal with empty list..
 306          if Param_List.Length = 0 then
 307             return Param;
 308          end if;
 309
 310          First_Param := Car (Param_List);
 311          Rest_Params := Cdr (Param_List);
 312          Rest_List := Deref_List (Rest_Params).all;
 313
 314          if Deref (First_Param).Sym_Type = Sym and then
 315             Deref_Sym (First_Param).Get_Sym = "def!" then
 316             return Def_Fn (Rest_List, Env);
 317          elsif Deref (First_Param).Sym_Type = Sym and then
 318                Deref_Sym (First_Param).Get_Sym = "defmacro!" then
 319             return Def_Macro (Rest_List, Env);
 320          elsif Deref (First_Param).Sym_Type = Sym and then
 321                Deref_Sym (First_Param).Get_Sym = "macroexpand" then
 322             return Macro_Expand (Car (Rest_List), Env);
 323          elsif Deref (First_Param).Sym_Type = Sym and then
 324                Deref_Sym (First_Param).Get_Sym = "let*" then
 325             declare
 326                Defs, Expr, Res : Mal_Handle;
 327                E : Envs.Env_Handle;
 328             begin
 329                E := Envs.New_Env (Env);
 330                Defs := Car (Rest_List);
 331                Deref_List_Class (Defs).Add_Defs (E);
 332                Expr := Car (Deref_List (Cdr (Rest_List)).all);
 333                Param := Expr;
 334                Env := E;
 335                goto Tail_Call_Opt;
 336                -- was:
 337                -- Res := Eval (Expr, E);
 338                -- return Res;
 339             end;
 340          elsif Deref (First_Param).Sym_Type = Sym and then
 341                Deref_Sym (First_Param).Get_Sym = "do" then
 342             declare
 343                D : List_Mal_Type;
 344                E : Mal_Handle;
 345             begin
 346
 347                if Debug then
 348                   Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List));
 349                end if;
 350
 351                if Is_Null (Rest_List) then
 352                   return Rest_Params;
 353                end if;
 354
 355                -- Loop processes Evals all but last entry
 356                D := Rest_List;
 357                loop
 358                   E := Car (D);
 359                   D := Deref_List (Cdr (D)).all;
 360                exit when Is_Null (D);
 361                   E := Eval (E, Env);
 362                end loop;
 363
 364                Param := E;
 365                goto Tail_Call_Opt;
 366
 367             end;
 368          elsif Deref (First_Param).Sym_Type = Sym and then
 369                Deref_Sym (First_Param).Get_Sym = "if" then
 370             declare
 371                Args : List_Mal_Type := Rest_List;
 372
 373                Cond, True_Part, False_Part : Mal_Handle;
 374                Cond_Bool : Boolean;
 375                pragma Assert (Length (Args) = 2 or Length (Args) = 3,
 376                               "If_Processing: not 2 or 3 parameters");
 377                L : List_Mal_Type;
 378             begin
 379
 380                Cond := Eval (Car (Args), Env);
 381
 382                Cond_Bool := Eval_As_Boolean (Cond);
 383
 384                if Cond_Bool then
 385                   L := Deref_List (Cdr (Args)).all;
 386
 387                   Param := Car (L);
 388                   goto Tail_Call_Opt;
 389                   -- was: return Eval (Car (L), Env);
 390                else
 391                   if Length (Args) = 3 then
 392                      L := Deref_List (Cdr (Args)).all;
 393                      L := Deref_List (Cdr (L)).all;
 394
 395                      Param := Car (L);
 396                      goto Tail_Call_Opt;
 397                      -- was: return Eval (Car (L), Env);
 398                   else
 399                      return New_Nil_Mal_Type;
 400                   end if;
 401                end if;
 402             end;
 403
 404          elsif Deref (First_Param).Sym_Type = Sym and then
 405                Deref_Sym (First_Param).Get_Sym = "fn*" then
 406
 407             return New_Lambda_Mal_Type
 408                      (Params => Car (Rest_List),
 409                       Expr => Nth (Rest_List, 1),
 410                       Env => Env);
 411
 412          elsif Deref (First_Param).Sym_Type = Sym and then
 413                Deref_Sym (First_Param).Get_Sym = "quote" then
 414
 415             return Car (Rest_List);
 416
 417          elsif Deref (First_Param).Sym_Type = Sym and then
 418                Deref_Sym (First_Param).Get_Sym = "quasiquote" then
 419
 420             Param := Quasi_Quote_Processing (Car (Rest_List));
 421             goto Tail_Call_Opt;
 422
 423          elsif Deref (First_Param).Sym_Type = Sym and then
 424                Deref_Sym (First_Param).Get_Sym = "try*" then
 425
 426             if Length (Rest_List) = 1 then
 427                return Eval (Car (Rest_List), Env);
 428             end if;
 429             declare
 430                Res : Mal_Handle;
 431             begin
 432                return Eval (Car (Rest_List), Env);
 433             exception
 434                when Mal_Exception =>
 435                   Res := Catch_Processing
 436                            (Cdr (Rest_List),
 437                             Types.Mal_Exception_Value,
 438                             Env);
 439                   Types.Mal_Exception_Value :=
 440                     Smart_Pointers.Null_Smart_Pointer;
 441                   return Res;
 442                when E : others =>
 443                   return Catch_Processing
 444                            (Cdr (Rest_List),
 445                             New_String_Mal_Type
 446                               (Ada.Exceptions.Exception_Message (E)),
 447                             Env);
 448             end;
 449
 450          else
 451
 452             -- The APPLY section.
 453             declare
 454                Evaled_H : Mal_Handle;
 455             begin
 456                Evaled_H := Eval_Ast (Param, Env);
 457
 458                Param_List := Deref_List (Evaled_H).all;
 459
 460                First_Param := Car (Param_List);
 461                Rest_Params := Cdr (Param_List);
 462                Rest_List := Deref_List (Rest_Params).all;
 463
 464                if Deref (First_Param).Sym_Type = Func then
 465                   return Call_Func (Deref_Func (First_Param).all, Rest_Params);
 466                elsif Deref (First_Param).Sym_Type = Lambda then
 467                   declare
 468
 469                      L : Lambda_Mal_Type;
 470                      E : Envs.Env_Handle;
 471                      Param_Names : List_Mal_Type;
 472                      Res : Mal_Handle;
 473
 474                   begin
 475
 476                      L := Deref_Lambda (First_Param).all;
 477                      E := Envs.New_Env (L.Get_Env);
 478
 479                      Param_Names := Deref_List (L.Get_Params).all;
 480
 481                      if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then
 482
 483                         Param := L.Get_Expr;
 484                         Env := E;
 485                         goto Tail_Call_Opt;
 486                         -- was: return Eval (L.Get_Expr, E);
 487
 488                      else
 489
 490                         raise Runtime_Exception with "Bind failed in Apply";
 491
 492                      end if;
 493
 494                   end;
 495
 496                else  -- neither a Lambda or a Func
 497                   raise Runtime_Exception with "Deref called on non-Func/Lambda";
 498                end if;
 499
 500             end;
 501
 502          end if;
 503
 504       else -- not a List_List
 505
 506          return Eval_Ast (Param, Env);
 507
 508       end if;
 509
 510    end Eval;
 511
 512
 513    function Print (Param : Types.Mal_Handle) return String is
 514    begin
 515       return Printer.Pr_Str (Param);
 516    end Print;
 517
 518    function Rep (Param : String; Env : Envs.Env_Handle) return String is
 519       AST, Evaluated_AST : Types.Mal_Handle;
 520    begin
 521
 522       AST := Read (Param);
 523
 524       if Types.Is_Null (AST) then
 525          return "";
 526       else
 527          Evaluated_AST := Eval (AST, Env);
 528          return Print (Evaluated_AST);
 529       end if;
 530
 531    end Rep;
 532
 533
 534    Repl_Env : Envs.Env_Handle;
 535
 536
 537    -- These two ops use Repl_Env directly.
 538
 539
 540    procedure RE (Str : Mal_String) is
 541       Discarded : Mal_Handle;
 542    begin
 543       Discarded := Eval (Read (Str), Repl_Env);
 544    end RE;
 545
 546
 547    function Do_Eval (Rest_Handle : Mal_Handle)
 548    return Types.Mal_Handle is
 549       First_Param : Mal_Handle;
 550       Rest_List : Types.List_Mal_Type;
 551    begin
 552       Rest_List := Deref_List (Rest_Handle).all;
 553       First_Param := Car (Rest_List);
 554       return Eval_Callback.Eval.all (First_Param, Repl_Env);
 555    end Do_Eval;
 556
 557
 558    Cmd_Args, File_Param : Natural;
 559    Command_Args : Types.Mal_Handle;
 560    Command_List : Types.List_Ptr;
 561    File_Processed : Boolean := False;
 562
 563 begin
 564
 565    -- Save a function pointer back to the Eval function.
 566    -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK
 567    -- as we know Eval will be in scope for the lifetime of the program.
 568    Eval_Callback.Eval := Eval'Unrestricted_Access;
 569
 570    Repl_Env := Envs.New_Env;
 571
 572    -- Core init also creates the first environment.
 573    -- This is needed for the def!'s below.
 574    Core.Init (Repl_Env);
 575
 576    -- Register the eval command.  This needs to be done here rather than Core.Init
 577    -- as it requires direct access to Repl_Env.
 578    Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access));
 579
 580    RE ("(def! not (fn* (a) (if a false true)))");
 581    RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))");
 582    RE ("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ""odd number of forms to cond"")) (cons 'cond (rest (rest xs)))))))");
 583
 584    -- Command line processing.
 585
 586    Cmd_Args := 0;
 587    Command_Args := Types.New_List_Mal_Type (Types.List_List);
 588    Command_List := Types.Deref_List (Command_Args);
 589
 590    while Ada.Command_Line.Argument_Count > Cmd_Args loop
 591
 592      Cmd_Args := Cmd_Args + 1;
 593      if Ada.Command_Line.Argument (Cmd_Args) = "-d" then
 594         Debug := True;
 595      elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then
 596         Envs.Debug := True;
 597      elsif not File_Processed then
 598         File_Param := Cmd_Args;
 599         File_Processed := True;
 600      else
 601         Command_List.Append
 602           (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args)));
 603      end if;
 604
 605    end loop;
 606
 607    Envs.Set (Repl_Env, "*ARGV*", Command_Args);
 608
 609    if File_Processed then
 610       RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)");
 611    else
 612       RE("(println (str ""Mal ["" *host-language* ""]""))");
 613       loop
 614          begin
 615             Ada.Text_IO.Put ("user> ");
 616             exit when Ada.Text_IO.End_Of_File;
 617             Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env));
 618          exception
 619             when E : others =>
 620                Ada.Text_IO.Put_Line
 621                  (Ada.Text_IO.Standard_Error,
 622                   "Error: " & Ada.Exceptions.Exception_Information (E));
 623                if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then
 624                   Ada.Text_IO.Put_Line
 625                     (Ada.Text_IO.Standard_Error,
 626                      Printer.Pr_Str (Types.Mal_Exception_Value));
 627                   Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer;
 628                end if;
 629          end;
 630       end loop;
 631    end if;
 632 end StepA_Mal;