ada/evaluation.adb

   1 with Ada.Text_IO;
   2 with Ada.Exceptions;
   3 with Envs;
   4 with Smart_Pointers;
   5
   6 package body Evaluation is
   7
   8    use Types;
   9
  10    procedure Add_Defs (Defs : List_Mal_Type; Env : Envs.Env_Handle) is
  11       D, L : List_Mal_Type;
  12    begin
  13       if Debug then
  14          Ada.Text_IO.Put_Line ("Add_Defs " & To_String (Defs));
  15       end if;
  16       D := Defs;
  17       while not Is_Null (D) loop
  18          L := Deref_List (Cdr (D)).all;
  19          Envs.Set
  20            (Env,
  21             Deref_Atom (Car (D)).Get_Atom,
  22             Eval (Car (L), Env));
  23          D := Deref_List (Cdr(L)).all;
  24       end loop;
  25    end Add_Defs;
  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 = Atom,
  34                      "Def_Fn: expected atom as name");
  35       Fn_Body := Car (Deref_List (Cdr (Args)).all);
  36       Res := Eval (Fn_Body, Env);
  37       Envs.Set (Envs.Get_Current, Deref_Atom (Name).Get_Atom, 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 = Atom,
  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 (Envs.Get_Current, Deref_Atom (Name).Get_Atom, 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 Let_Processing (Args : List_Mal_Type; Env : Envs.Env_Handle)
 107                            return Mal_Handle is
 108       Defs, Expr, Res : Mal_Handle;
 109       E : Envs.Env_Handle;
 110    begin
 111       E := Envs.New_Env (Env);
 112       Defs := Car (Args);
 113       Add_Defs (Deref_List (Defs).all, E);
 114       Expr := Car (Deref_List (Cdr (Args)).all);
 115       Res := Eval (Expr, E);
 116       return Res;
 117    end Let_Processing;
 118
 119
 120    function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
 121       Res : Boolean;
 122    begin
 123       case Deref (MH).Sym_Type is
 124          when Bool =>
 125             Res := Deref_Bool (MH).Get_Bool;
 126          when Atom =>
 127             return not (Deref_Atom (MH).Get_Atom = "nil");
 128 --         when List =>
 129 --            declare
 130 --               L : List_Mal_Type;
 131 --            begin
 132 --               L := Deref_List (MH).all;
 133 --               Res := not Is_Null (L);
 134 --            end;
 135          when others => -- Everything else
 136             Res := True;
 137       end case;
 138       return Res;
 139    end Eval_As_Boolean;
 140
 141
 142    function Eval_Ast
 143      (Ast : Mal_Handle; Env : Envs.Env_Handle)
 144      return Mal_Handle is
 145
 146       function Call_Eval (A : Mal_Handle) return Mal_Handle is
 147       begin
 148          return Eval (A, Env);
 149       end Call_Eval;
 150
 151    begin
 152
 153       case Deref (Ast).Sym_Type is
 154
 155          when Atom =>
 156
 157             declare
 158                Sym : Mal_String := Deref_Atom (Ast).Get_Atom;
 159             begin
 160                -- if keyword or nil (which may represent False)...
 161                if Sym(1) = ':' then
 162                   return Ast;
 163                else
 164                   return Envs.Get (Env, Sym);
 165                end if;
 166             exception
 167                when Envs.Not_Found =>
 168                   raise Envs.Not_Found with (" '" &  Sym & "' not found ");
 169             end;
 170
 171          when List =>
 172
 173             return Map (Call_Eval'Unrestricted_Access, Deref_List (Ast).all);
 174
 175          when Lambda =>
 176
 177             -- Evaluating a lambda in a different Env.
 178             declare
 179                L : Lambda_Ptr;
 180                New_Env : Envs.Env_Handle;
 181             begin
 182                L := Deref_Lambda (Ast);
 183                New_Env := Env;
 184                -- Make the current Lambda's env the outer of the env param.
 185                Envs.Set_Outer (New_Env, L.Get_Env);
 186                -- Make the Lambda's Env.
 187                L.Set_Env (New_Env);
 188                return Ast;
 189             end;
 190
 191          when others => return Ast;
 192
 193       end case;
 194
 195    end Eval_Ast;
 196
 197
 198    function Do_Processing (Do_List : List_Mal_Type; Env : Envs.Env_Handle)
 199                           return Mal_Handle is
 200       D : List_Mal_Type;
 201       Res : Mal_Handle := Smart_Pointers.Null_Smart_Pointer;
 202    begin
 203       if Debug then
 204          Ada.Text_IO.Put_Line ("Do-ing " & To_String (Do_List));
 205       end if;
 206       D := Do_List;
 207       while not Is_Null (D) loop
 208          Res := Eval (Car (D), Env);
 209          D := Deref_List (Cdr(D)).all;
 210       end loop;
 211       return Res;
 212    end Do_Processing;
 213
 214
 215    function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is
 216       Res, First_Elem, FE_0 : Mal_Handle;
 217       D, Ast : List_Mal_Type;
 218       L : List_Ptr;
 219    begin
 220
 221       if Debug then
 222          Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String);
 223       end if;
 224
 225       -- Create a New List for the result...
 226       Res := New_List_Mal_Type (List_List);
 227       L := Deref_List (Res);
 228
 229       -- This is the equivalent of Is_Pair
 230       if Deref (Param).Sym_Type /= List or else
 231          Is_Null (Deref_List (Param).all) then
 232
 233          -- return a new list containing: a symbol named "quote" and ast.
 234          L.Append (New_Atom_Mal_Type ("quote"));
 235          L.Append (Param);
 236          return Res;
 237
 238       end if;
 239
 240       -- Ast is a non-empty list at this point.
 241
 242       Ast := Deref_List (Param).all;
 243
 244       First_Elem := Car (Ast);
 245
 246       -- if the first element of ast is a symbol named "unquote":
 247       if Deref (First_Elem).Sym_Type = Atom and then
 248          Deref_Atom (First_Elem).Get_Atom = "unquote" then
 249
 250          -- return the second element of ast.`
 251          D := Deref_List (Cdr (Ast)).all;
 252          return Car (D);
 253
 254       end if;
 255
 256       -- if the first element of first element of `ast` (`ast[0][0]`)
 257       -- is a symbol named "splice-unquote"
 258       if Deref (First_Elem).Sym_Type = List and then
 259          not Is_Null (Deref_List (First_Elem).all) then
 260
 261          D := Deref_List (First_Elem).all;
 262          FE_0 := Car (D);
 263
 264          if Deref (FE_0).Sym_Type = Atom and then
 265             Deref_Atom (FE_0).Get_Atom = "splice-unquote" then
 266
 267             -- return a new list containing: a symbol named "concat",
 268             L.Append (New_Atom_Mal_Type ("concat"));
 269
 270             -- the second element of first element of ast (ast[0][1]),
 271             D := Deref_List (Cdr (D)).all;
 272             L.Append (Car (D));
 273
 274             -- and the result of calling quasiquote with
 275             -- the second through last element of ast.
 276             L.Append (Quasi_Quote_Processing (Cdr (Ast)));
 277
 278             return Res;
 279
 280          end if;
 281
 282       end if;
 283
 284       -- otherwise: return a new list containing: a symbol named "cons",
 285       L.Append (New_Atom_Mal_Type ("cons"));
 286
 287       -- the result of calling quasiquote on first element of ast (ast[0]),
 288       L.Append (Quasi_Quote_Processing (Car (Ast)));
 289
 290       -- and result of calling quasiquote with the second through last element of ast.
 291       L.Append (Quasi_Quote_Processing (Cdr (Ast)));
 292
 293       return Res;
 294
 295    end Quasi_Quote_Processing;
 296
 297
 298    function Catch_Processing
 299               (Try_Line : Mal_Handle;
 300                ExStr : Mal_Handle;
 301                Env : Envs.Env_Handle)
 302    return Mal_Handle is
 303
 304       L, CL, CL2, CL3 : List_Mal_Type;
 305       C : Mal_Handle;
 306       New_Env : Envs.Env_Handle;
 307
 308    begin
 309
 310       L := Deref_List (Try_Line).all;
 311       C := Car (L);
 312       -- CL is the list with the catch in.
 313       CL := Deref_List (C).all;
 314
 315       CL2 := Deref_List (Cdr (CL)).all;
 316       New_Env := Envs.New_Env (Env);
 317       Envs.Set (New_Env, Deref_Atom (Car (CL2)).Get_Atom, ExStr);
 318
 319       CL3 := Deref_List (Cdr (CL2)).all;
 320       return Eval (Car (CL3), New_Env);
 321    end Catch_Processing;
 322
 323    Mal_Exception_Value : Mal_Handle;
 324
 325    function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
 326                  return Mal_Handle is
 327       Param : Mal_Handle;
 328       Env : Envs.Env_Handle;
 329       First_Elem : Mal_Handle;
 330    begin
 331
 332       Param := AParam;
 333       Env := AnEnv;
 334
 335   <<Tail_Call_Opt>>
 336
 337       if Debug then
 338          Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
 339       end if;
 340
 341       Param := Macro_Expand (Param, Env);
 342
 343       if Debug then
 344          Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String);
 345       end if;
 346
 347       if Deref (Param).Sym_Type = List and then
 348         Deref_List (Param).all.Get_List_Type = List_List then
 349
 350          declare
 351             L : Mal_Handle := Param;
 352             LMT, Rest_List : List_Mal_Type;
 353             First_Elem, Rest_Handle : Mal_Handle;
 354          begin
 355
 356             LMT := Deref_List (L).all;
 357
 358             First_Elem := Car (LMT);
 359
 360             Rest_Handle := Cdr (LMT);
 361
 362             Rest_List := Deref_List (Rest_Handle).all;
 363
 364             case Deref (First_Elem).Sym_Type is
 365
 366                when Int | Floating | Bool | Str =>
 367
 368                   return First_Elem;
 369
 370                when Atom =>
 371
 372                   declare
 373                      Atom_P : Atom_Ptr;
 374                   begin
 375                      Atom_P := Deref_Atom (First_Elem);
 376                      if Atom_P.Get_Atom = "def!" then
 377                         return Def_Fn (Rest_List, Env);
 378                      elsif Atom_P.Get_Atom = "defmacro!" then
 379                         return Def_Macro (Rest_List, Env);
 380                      elsif Atom_P.Get_Atom = "macroexpand" then
 381                         return Macro_Expand (Car (Rest_List), Env);
 382                      elsif Atom_P.Get_Atom = "let*" then
 383                         return Let_Processing (Rest_List, Env);
 384                      elsif Atom_P.Get_Atom = "do" then
 385                         return Do_Processing (Rest_List, Env);
 386                      elsif Atom_P.Get_Atom = "if" then
 387                         declare
 388                            Args : List_Mal_Type := Rest_List;
 389
 390                            Cond, True_Part, False_Part : Mal_Handle;
 391                            Cond_Bool : Boolean;
 392                            pragma Assert (Length (Args) = 2 or Length (Args) = 3,
 393                                           "If_Processing: not 2 or 3 parameters");
 394                            L : List_Mal_Type;
 395                         begin
 396
 397                            Cond := Eval (Car (Args), Env);
 398
 399                            Cond_Bool := Eval_As_Boolean (Cond);
 400
 401                            if Cond_Bool then
 402                               L := Deref_List (Cdr (Args)).all;
 403
 404                               Param := Car (L);
 405                               goto Tail_Call_Opt;
 406                               -- was: return Eval (Car (L), Env);
 407                            else
 408                               if Length (Args) = 3 then
 409                                  L := Deref_List (Cdr (Args)).all;
 410                                  L := Deref_List (Cdr (L)).all;
 411
 412                                  Param := Car (L);
 413                                  goto Tail_Call_Opt;
 414                                  -- was: return Eval (Car (L), Env);
 415                               else
 416                                  return New_Atom_Mal_Type ("nil");
 417                               end if;
 418                            end if;
 419                         end;
 420
 421                      elsif Atom_P.Get_Atom = "quote" then
 422                         return Car (Rest_List);
 423                      elsif Atom_P.Get_Atom = "quasiquote" then
 424                         Param := Quasi_Quote_Processing (Car (Rest_List));
 425                         goto Tail_Call_Opt;
 426                      elsif Atom_P.Get_Atom = "try*" then
 427                         declare
 428                            Res : Mal_Handle;
 429                         begin
 430                            return Eval (Car (Rest_List), Env);
 431                         exception
 432                            when Mal_Exception =>
 433                               Res := Catch_Processing
 434                                        (Cdr (Rest_List),
 435                                         Mal_Exception_Value,
 436                                         Env);
 437                               Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer;
 438                               return Res;
 439                            when E : others =>
 440                               return Catch_Processing
 441                                        (Cdr (Rest_List),
 442                                         New_String_Mal_Type
 443                                           (Ada.Exceptions.Exception_Message (E)),
 444                                         Env);
 445                         end;
 446                      elsif Atom_P.Get_Atom = "throw" then
 447                          Mal_Exception_Value := Eval (Car (Rest_List), Env);
 448                          raise Mal_Exception;
 449                      else -- not a special form
 450
 451                         -- Apply section
 452                         declare
 453                            Res : Mal_Handle;
 454                         begin
 455                            -- Eval the atom.
 456                            Res := Eval_Ast (L, Env);
 457                            Param := Res;
 458                            goto Tail_Call_Opt;
 459                            -- was: return Eval (Res, Env);
 460                         end;
 461
 462                      end if;
 463                   end;
 464
 465                when Func =>
 466
 467                   return Call_Func
 468                     (Deref_Func (First_Elem).all,
 469                      Rest_Handle,
 470                      Env);
 471
 472                when Lambda =>
 473
 474                   declare
 475                      LP : Lambda_Ptr := Deref_Lambda (First_Elem);
 476                      Fn_List : Mal_Handle := Cdr (LMT);
 477                      Params : List_Mal_Type;
 478                      E : Envs.Env_Handle;
 479                   begin
 480                      E := Envs.New_Env (LP.Get_Env);
 481                      Params := Deref_List (LP.Get_Params).all;
 482                      if Envs.Bind (E, Params, Deref_List (Fn_List).all) then
 483
 484                         Param := LP.Get_Expr;
 485                         Env := E;
 486                         goto Tail_Call_Opt;
 487                         -- was: return Eval (LP.Get_Expr, E);
 488
 489                      else
 490                         return First_Elem;
 491                      end if;
 492
 493                   end;
 494
 495                when List =>
 496
 497                   -- First elem in the list is a list.
 498                   -- Eval it and then insert it as first elem in the list and
 499                   -- go again.
 500                   declare
 501                      Evaled_List : Mal_Handle;
 502                      E : Envs.Env_Handle;
 503                   begin
 504                      Evaled_List := Eval (First_Elem, Env);
 505                      if Is_Null (Evaled_List) then
 506                         return Evaled_List;
 507                      elsif Deref (Evaled_List).Sym_Type = Lambda then
 508                         E := Deref_Lambda (Evaled_List).Get_Env;
 509                      else
 510                         E := Env;
 511                      end if;
 512
 513                      Param := Prepend (Evaled_List, Rest_List);
 514                      Env := E;
 515                      goto Tail_Call_Opt;
 516                      -- was:
 517                      -- Evaled_List := Prepend (Evaled_List, Rest_List);
 518                      -- return Eval (Evaled_List, E);
 519                   end;
 520
 521                when Error => return First_Elem;
 522
 523                when Node => return New_Error_Mal_Type ("Evaluating a node");
 524
 525                when Unitary => null; -- Not yet impl
 526
 527             end case;
 528
 529          end;
 530
 531       elsif Deref (Param).Sym_Type = Unitary then
 532          declare
 533             UMT : Types.Unitary_Mal_Type;
 534          begin
 535             UMT := Deref_Unitary (Param).all;
 536             case UMT.Get_Func is
 537                when Quote =>
 538                   return UMT.Get_Op;
 539                when QuasiQuote =>
 540                   Param := Quasi_Quote_Processing (UMT.Get_Op);
 541                   goto Tail_Call_Opt;
 542                when Unquote =>
 543                   Param := UMT.Get_Op;
 544                   goto Tail_Call_Opt;
 545                when others => null;
 546             end case;
 547          end;
 548       else
 549
 550          return Eval_Ast (Param, Env);
 551
 552       end if;
 553
 554    end Eval;
 555
 556
 557 end Evaluation;