ada/types.adb

   1 with Ada.Characters.Latin_1;
   2 with Ada.Strings.Fixed;
   3 with Ada.Strings.Maps.Constants;
   4 with Ada.Text_IO;
   5 with Ada.Unchecked_Deallocation;
   6 with Envs;
   7 with Eval_Callback;
   8 with Smart_Pointers;
   9 with Types.Vector;
  10 with Types.Hash_Map;
  11
  12 package body Types is
  13
  14    package ACL renames Ada.Characters.Latin_1;
  15
  16    function Nodes_Equal (A, B : Mal_Handle) return Boolean;
  17
  18
  19    function "=" (A, B : Mal_Handle) return Mal_Handle is
  20    begin
  21       return New_Bool_Mal_Type (A = B);
  22    end "=";
  23
  24
  25    function Compare_List_And_Vector (A : List_Mal_Type; B : List_Mal_Type'Class)
  26    return Boolean is
  27       First_Node, First_Index : Mal_Handle;
  28       I : Natural := 0;
  29    begin
  30       First_Node := A.The_List;
  31       loop
  32          if not Is_Null (First_Node) and I < B.Length then
  33             First_Index := B.Nth (I);
  34             if not "=" (Deref_Node (First_Node).Data, First_Index) then
  35                return False;
  36             end if;
  37             First_Node := Deref_Node (First_Node).Next;
  38             I := I + 1;
  39          else
  40             return Is_Null (First_Node) and I = B.Length;
  41          end if;
  42       end loop;
  43    end Compare_List_And_Vector;
  44
  45
  46    function "=" (A, B : Mal_Handle) return Boolean is
  47       use Types.Vector;
  48       use Types.Hash_Map;
  49    begin
  50
  51       if (not Is_Null (A) and not Is_Null (B)) and then
  52          Deref (A).Sym_Type = Deref (B).Sym_Type then
  53
  54          case Deref (A).Sym_Type is
  55             when Nil =>
  56                return True; -- Both nil.
  57             when Int =>
  58                return (Deref_Int (A).Get_Int_Val = Deref_Int (B).Get_Int_Val);
  59             when Floating =>
  60                return (Deref_Float (A).Get_Float_Val = Deref_Float (B).Get_Float_Val);
  61             when Bool =>
  62                return (Deref_Bool (A).Get_Bool = Deref_Bool (B).Get_Bool);
  63             when List =>
  64             -- When Types.Vector was added, the choice was:
  65             -- 1) use interfaces (because you need a class hierachy for the containers
  66             --    and a corresponding hierarchy for the cursors and Ada is single dispatch
  67             --    + interfaces.
  68             -- 2) map out the combinations here and use nth to access vector items.
  69                case Deref_List (A).Get_List_Type is
  70                   when List_List =>
  71                      case Deref_List (B).Get_List_Type is
  72                         when List_List =>
  73                            return Nodes_Equal (Deref_List (A).The_List, Deref_List (B).The_List);
  74                         when Vector_List =>
  75                            return Compare_List_And_Vector
  76                                     (Deref_List (A).all, Deref_List_Class (B).all);
  77                         when Hashed_List => return False; -- Comparing a list and a hash
  78                      end case;
  79                   when Vector_List =>
  80                      case Deref_List (B).Get_List_Type is
  81                         when List_List =>
  82                            return Compare_List_And_Vector
  83                                     (Deref_List (B).all, Deref_List_Class (A).all);
  84                         when Vector_List =>
  85                            return Vector."=" (Deref_Vector (A).all, Deref_Vector (B).all);
  86                         when Hashed_List => return False; -- Comparing a vector and a hash
  87                      end case;
  88                   when Hashed_List =>
  89                      case Deref_List (B).Get_List_Type is
  90                         when List_List => return False; -- Comparing a list and a hash
  91                         when Vector_List => return False; -- Comparing a vector and a hash
  92                         when Hashed_List =>
  93                            return Hash_Map."=" (Deref_Hash (A).all, Deref_Hash (B).all);
  94                      end case;
  95                end case;
  96             when Str =>
  97                return (Deref_String (A).Get_String = Deref_String (B).Get_String);
  98             when Sym =>
  99                return (Deref_Sym (A).Get_Sym = Deref_Sym (B).Get_Sym);
 100             when Atom =>
 101                return (Deref_Atom (A).Get_Atom = Deref_Atom (B).Get_Atom);
 102             when Func =>
 103                return (Deref_Func (A).Get_Func_Name = Deref_Func (B).Get_Func_Name);
 104             when Node =>
 105                return (Deref_Int(A).Get_Int_Val = Deref_Int(B).Get_Int_Val);
 106             when Lambda =>
 107                return (Deref_Int(A).Get_Int_Val = Deref_Int(B).Get_Int_Val);
 108             when Error =>
 109                return (Deref_Int(A).Get_Int_Val = Deref_Int(B).Get_Int_Val);
 110           end case;
 111       elsif Is_Null (A) and Is_Null (B) then
 112          return True;
 113       else  -- either one of the args is null or the sym_types don't match
 114          return False;
 115       end if;
 116    end "=";
 117
 118    function Get_Meta (T : Mal_Type) return Mal_Handle is
 119    begin
 120        if T.Meta = Smart_Pointers.Null_Smart_Pointer then
 121           return New_Nil_Mal_Type;
 122        else
 123           return T.Meta;
 124        end if;
 125    end Get_Meta;
 126
 127    procedure Set_Meta (T : in out Mal_Type'Class; SP : Mal_Handle) is
 128    begin
 129       T.Meta := SP;
 130    end Set_Meta;
 131
 132    function Copy (M : Mal_Handle) return Mal_Handle is
 133    begin
 134       return Smart_Pointers.New_Ptr
 135         (new Mal_Type'Class'(Deref (M).all));
 136    end Copy;
 137
 138    function To_String (T : Mal_Type'Class; Print_Readably : Boolean := True)
 139    return Mal_String is
 140    begin
 141       return To_Str (T, Print_Readably);
 142    end To_String;
 143
 144    function Is_Macro_Call (T : Mal_Type'Class; Env : Envs.Env_Handle) return Boolean is
 145       L : List_Mal_Type;
 146       First_Elem, Func : Mal_Handle;
 147    begin
 148
 149       if T.Sym_Type /= List then
 150          return False;
 151       end if;
 152
 153       L := List_Mal_Type (T);
 154
 155       if Is_Null (L) then
 156          return False;
 157       end if;
 158
 159       First_Elem := Car (L);
 160
 161       if Deref (First_Elem).Sym_Type /= Sym then
 162          return False;
 163       end if;
 164
 165       Func := Envs.Get (Env, Deref_Sym (First_Elem).Get_Sym);
 166
 167       if Deref (Func).Sym_Type /= Lambda then
 168          return False;
 169       end if;
 170
 171       return Deref_Lambda (Func).Get_Is_Macro;
 172
 173    exception
 174       when Envs.Not_Found => return False;
 175    end Is_Macro_Call;
 176
 177
 178    -- A helper function that just view converts the smart pointer.
 179    function Deref (S : Mal_Handle) return Mal_Ptr is
 180    begin
 181       return Mal_Ptr (Smart_Pointers.Deref (S));
 182    end Deref;
 183
 184    -- A helper function to detect null smart pointers.
 185    function Is_Null (S : Mal_Handle) return Boolean is
 186       use Smart_Pointers;
 187    begin
 188       return Smart_Pointers."="(S, Null_Smart_Pointer);
 189    end Is_Null;
 190
 191
 192    -- To_Str on the abstract type...
 193    function To_Str (T : Mal_Type; Print_Readably : Boolean := True)
 194    return Mal_String is
 195    begin
 196       raise Constraint_Error;  -- Tha'll teach 'ee
 197       return "";  -- Keeps the compiler happy.
 198    end To_Str;
 199
 200
 201    function New_Nil_Mal_Type return Mal_Handle is
 202    begin
 203       return Smart_Pointers.New_Ptr
 204         (new Nil_Mal_Type'(Mal_Type with null record));
 205    end New_Nil_Mal_Type;
 206
 207    overriding function Sym_Type (T : Nil_Mal_Type) return Sym_Types is
 208    begin
 209       return Nil;
 210    end Sym_Type;
 211
 212    overriding function To_Str (T : Nil_Mal_Type; Print_Readably : Boolean := True)
 213    return Mal_String is
 214    begin
 215       return "nil";
 216    end To_Str;
 217
 218
 219    function New_Int_Mal_Type (Int : Mal_Integer) return Mal_Handle is
 220    begin
 221       return Smart_Pointers.New_Ptr
 222         (new Int_Mal_Type'(Mal_Type with Int_Val => Int));
 223    end New_Int_Mal_Type;
 224
 225    overriding function Sym_Type (T : Int_Mal_Type) return Sym_Types is
 226    begin
 227       return Int;
 228    end Sym_Type;
 229
 230    function Get_Int_Val (T : Int_Mal_Type) return Mal_Integer is
 231    begin
 232       return T.Int_Val;
 233    end Get_Int_Val;
 234
 235    overriding function To_Str
 236      (T : Int_Mal_Type; Print_Readably : Boolean := True)
 237    return Mal_String is
 238       Res : Mal_String := Mal_Integer'Image (T.Int_Val);
 239    begin
 240       return Ada.Strings.Fixed.Trim (Res, Ada.Strings.Left);
 241    end To_Str;
 242
 243    function Deref_Int (SP : Mal_Handle) return Int_Ptr is
 244    begin
 245       return Int_Ptr (Deref (SP));
 246    end Deref_Int;
 247
 248
 249    function New_Float_Mal_Type (Floating : Mal_Float) return Mal_Handle is
 250    begin
 251       return Smart_Pointers.New_Ptr
 252         (new Float_Mal_Type'(Mal_Type with Float_Val => Floating));
 253    end New_Float_Mal_Type;
 254
 255    overriding function Sym_Type (T : Float_Mal_Type) return Sym_Types is
 256    begin
 257       return Floating;
 258    end Sym_Type;
 259
 260    function Get_Float_Val (T : Float_Mal_Type) return Mal_Float is
 261    begin
 262       return T.Float_Val;
 263    end Get_Float_Val;
 264
 265    overriding function To_Str
 266      (T : Float_Mal_Type; Print_Readably : Boolean := True)
 267    return Mal_String is
 268       Res : Mal_String := Mal_Float'Image (T.Float_Val);
 269    begin
 270       return Ada.Strings.Fixed.Trim (Res, Ada.Strings.Left);
 271    end To_Str;
 272
 273    function Deref_Float (SP : Mal_Handle) return Float_Ptr is
 274    begin
 275       return Float_Ptr (Deref (SP));
 276    end Deref_Float;
 277
 278
 279    function New_Bool_Mal_Type (Bool : Boolean) return Mal_Handle is
 280    begin
 281       return Smart_Pointers.New_Ptr
 282         (new Bool_Mal_Type'(Mal_Type with Bool_Val => Bool));
 283    end New_Bool_Mal_Type;
 284
 285    overriding function Sym_Type (T : Bool_Mal_Type) return Sym_Types is
 286    begin
 287       return Bool;
 288    end Sym_Type;
 289
 290    function Get_Bool (T : Bool_Mal_Type) return Boolean is
 291    begin
 292       return T.Bool_Val;
 293    end Get_Bool;
 294
 295    overriding function To_Str
 296      (T : Bool_Mal_Type; Print_Readably : Boolean := True)
 297    return Mal_String is
 298       Res : Mal_String := Boolean'Image (T.Bool_Val);
 299    begin
 300      return Ada.Strings.Fixed.Translate
 301               (Res, Ada.Strings.Maps.Constants.Lower_Case_Map);
 302    end To_Str;
 303
 304    function Deref_Bool (SP : Mal_Handle) return Bool_Ptr is
 305    begin
 306       return Bool_Ptr (Deref (SP));
 307    end Deref_Bool;
 308
 309
 310    function New_String_Mal_Type (Str : Mal_String) return Mal_Handle is
 311    begin
 312       return Smart_Pointers.New_Ptr
 313         (new String_Mal_Type' (Mal_Type with The_String =>
 314            Ada.Strings.Unbounded.To_Unbounded_String (Str)));
 315    end New_String_Mal_Type;
 316
 317    overriding function Sym_Type (T : String_Mal_Type) return Sym_Types is
 318    begin
 319       return Str;
 320    end Sym_Type;
 321
 322    function Get_String (T : String_Mal_Type) return Mal_String is
 323    begin
 324       return Ada.Strings.Unbounded.To_String (T.The_String);
 325    end Get_String;
 326
 327    function Deref_String (SP : Mal_Handle) return String_Ptr is
 328    begin
 329       return String_Ptr (Deref (SP));
 330    end Deref_String;
 331
 332
 333    overriding function To_Str
 334      (T : String_Mal_Type; Print_Readably : Boolean := True)
 335    return Mal_String is
 336       use Ada.Strings.Unbounded;
 337       I : Positive := 1;
 338       Str_Len : Natural;
 339       Res : Unbounded_String;
 340       Ch : Character;
 341    begin
 342       if Print_Readably then
 343          Append (Res, '"');
 344          Str_Len := Length (T.The_String);
 345          while I <= Str_Len loop
 346             Ch := Element (T.The_String, I);
 347             if Ch = '"' then
 348                Append (Res, "\""");
 349             elsif Ch = '\' then
 350                Append (Res, "\\");
 351             elsif Ch = Ada.Characters.Latin_1.LF then
 352                Append (Res, "\n");
 353             else
 354                Append (Res, Ch);
 355             end if;
 356             I := I + 1;
 357          end loop;
 358          Append (Res, '"');
 359          return To_String (Res);
 360       else
 361          return To_String (T.The_String);
 362       end if;
 363    end To_Str;
 364
 365
 366    function New_Symbol_Mal_Type (Str : Mal_String) return Mal_Handle is
 367    begin
 368       return Smart_Pointers.New_Ptr
 369         (new Symbol_Mal_Type'(Mal_Type with The_Symbol =>
 370            Ada.Strings.Unbounded.To_Unbounded_String (Str)));
 371    end New_Symbol_Mal_Type;
 372
 373    overriding function Sym_Type (T : Symbol_Mal_Type) return Sym_Types is
 374    begin
 375       return Sym;
 376    end Sym_Type;
 377
 378    function Get_Sym (T : Symbol_Mal_Type) return Mal_String is
 379    begin
 380       return Ada.Strings.Unbounded.To_String (T.The_Symbol);
 381    end Get_Sym;
 382
 383    function Deref_Sym (S : Mal_Handle) return Sym_Ptr is
 384    begin
 385       return Sym_Ptr (Deref (S));
 386    end Deref_Sym;
 387
 388    overriding function To_Str
 389      (T : Symbol_Mal_Type; Print_Readably : Boolean := True)
 390    return Mal_String is
 391    begin
 392       return Ada.Strings.Unbounded.To_String (T.The_Symbol);
 393    end To_Str;
 394
 395
 396    function New_Atom_Mal_Type (MH : Mal_Handle) return Mal_Handle is
 397    begin
 398       return Smart_Pointers.New_Ptr
 399         (new Atom_Mal_Type'(Mal_Type with The_Atom => MH));
 400    end New_Atom_Mal_Type;
 401
 402    overriding function Sym_Type (T : Atom_Mal_Type) return Sym_Types is
 403    begin
 404       return Atom;
 405    end Sym_Type;
 406
 407    function Get_Atom (T : Atom_Mal_Type) return Mal_Handle is
 408    begin
 409       return T.The_Atom;
 410    end Get_Atom;
 411
 412    procedure Set_Atom (T : in out Atom_Mal_Type; New_Val : Mal_Handle) is
 413    begin
 414       T.The_Atom := New_Val;
 415    end Set_Atom;
 416
 417    function Deref_Atom (S : Mal_Handle) return Atom_Ptr is
 418    begin
 419       return Atom_Ptr (Deref (S));
 420    end Deref_Atom;
 421
 422    overriding function To_Str
 423      (T : Atom_Mal_Type; Print_Readably : Boolean := True)
 424    return Mal_String is
 425    begin
 426       return "(atom " & To_String (Deref (T.The_Atom).all) & ')';
 427    end To_Str;
 428
 429
 430    function New_Func_Mal_Type (Str : Mal_String; F : Builtin_Func)
 431    return Mal_Handle is
 432    begin
 433       return Smart_Pointers.New_Ptr
 434         (new Func_Mal_Type'(Mal_Type with
 435           Func_Name => Ada.Strings.Unbounded.To_Unbounded_String (Str),
 436           Func_P => F));
 437    end New_Func_Mal_Type;
 438
 439    overriding function Sym_Type (T : Func_Mal_Type) return Sym_Types is
 440    begin
 441       return Func;
 442    end Sym_Type;
 443
 444    function Get_Func_Name (T : Func_Mal_Type) return Mal_String is
 445    begin
 446       return Ada.Strings.Unbounded.To_String (T.Func_Name);
 447    end Get_Func_Name;
 448
 449    function Call_Func
 450      (FMT : Func_Mal_Type; Rest_List : Mal_Handle)
 451    return Mal_Handle is
 452    begin
 453       return FMT.Func_P (Rest_List);
 454    end Call_Func;
 455
 456    function Deref_Func (S : Mal_Handle) return Func_Ptr is
 457    begin
 458       return Func_Ptr (Deref (S));
 459    end Deref_Func;
 460
 461    overriding function To_Str
 462      (T : Func_Mal_Type; Print_Readably : Boolean := True)
 463    return Mal_String is
 464    begin
 465       return Ada.Strings.Unbounded.To_String (T.Func_Name);
 466    end To_Str;
 467
 468
 469    function New_Error_Mal_Type (Str : Mal_String) return Mal_Handle is
 470    begin
 471       return Smart_Pointers.New_Ptr
 472         (new Error_Mal_Type'(Mal_Type with Error_Msg =>
 473            Ada.Strings.Unbounded.To_Unbounded_String (Str)));
 474    end New_Error_Mal_Type;
 475
 476    overriding function Sym_Type (T : Error_Mal_Type) return Sym_Types is
 477    begin
 478       return Error;
 479    end Sym_Type;
 480
 481    overriding function To_Str
 482      (T : Error_Mal_Type; Print_Readably : Boolean := True)
 483    return Mal_String is
 484    begin
 485       return Ada.Strings.Unbounded.To_String (T.Error_Msg);
 486    end To_Str;
 487
 488
 489    function Nodes_Equal (A, B : Mal_Handle) return Boolean is
 490    begin
 491       if (not Is_Null (A) and not Is_Null (B)) and then
 492          Deref (A).Sym_Type = Deref (B).Sym_Type then
 493          if Deref (A).Sym_Type = Node then
 494             return
 495               Nodes_Equal (Deref_Node (A).Data, Deref_Node (B).Data) and then
 496               Nodes_Equal (Deref_Node (A).Next, Deref_Node (B).Next);
 497          else
 498             return A = B;
 499          end if;
 500       elsif Is_Null (A) and Is_Null (B) then
 501          return True;
 502       else  -- either one of the args is null or the sym_types don't match
 503          return False;
 504       end if;
 505    end Nodes_Equal;
 506
 507
 508    function New_Node_Mal_Type
 509      (Data : Mal_Handle;
 510       Next : Mal_Handle := Smart_Pointers.Null_Smart_Pointer)
 511    return Mal_Handle is
 512    begin
 513       return Smart_Pointers.New_Ptr
 514         (new Node_Mal_Type'
 515           (Mal_Type with Data => Data, Next => Next));
 516    end New_Node_Mal_Type;
 517
 518
 519    overriding function Sym_Type (T : Node_Mal_Type) return Sym_Types is
 520    begin
 521       return Node;
 522    end Sym_Type;
 523
 524
 525    -- Get the first item in the list:
 526    function Car (L : List_Mal_Type) return Mal_Handle is
 527    begin
 528       if Is_Null (L.The_List) then
 529          return Smart_Pointers.Null_Smart_Pointer;
 530       else
 531          return Deref_Node (L.The_List).Data;
 532       end if;
 533    end Car;
 534
 535
 536    -- Get the rest of the list (second item onwards)
 537    function Cdr (L : List_Mal_Type) return Mal_Handle is
 538       Res : Mal_Handle;
 539       LP : List_Ptr;
 540    begin
 541
 542       Res := New_List_Mal_Type (L.List_Type);
 543
 544       if Is_Null (L.The_List) or else
 545          Is_Null (Deref_Node (L.The_List).Next) then
 546          return Res;
 547       else
 548          LP := Deref_List (Res);
 549          LP.The_List := Deref_Node (L.The_List).Next;
 550          LP.Last_Elem := L.Last_Elem;
 551          return Res;
 552       end if;
 553    end Cdr;
 554
 555
 556    function Length (L : List_Mal_Type) return Natural is
 557       Res : Natural;
 558       NP : Node_Ptr;
 559    begin
 560       Res := 0;
 561       NP := Deref_Node (L.The_List);
 562       while NP /= null loop
 563          Res := Res + 1;
 564          NP := Deref_Node (NP.Next);
 565       end loop;
 566       return Res;
 567    end Length;
 568
 569
 570    function Is_Null (L : List_Mal_Type) return Boolean is
 571       use Smart_Pointers;
 572    begin
 573       return Smart_Pointers."="(L.The_List, Null_Smart_Pointer);
 574    end Is_Null;
 575
 576
 577    function Null_List (L : List_Types) return List_Mal_Type is
 578    begin
 579       return (Mal_Type with List_Type => L,
 580               The_List => Smart_Pointers.Null_Smart_Pointer,
 581               Last_Elem => Smart_Pointers.Null_Smart_Pointer);
 582    end Null_List;
 583
 584
 585    function Map
 586      (Func_Ptr : Func_Access;
 587       L : List_Mal_Type)
 588    return Mal_Handle is
 589
 590       Res, Old_List, First_New_Node, New_List : Mal_Handle;
 591       LP : List_Ptr;
 592
 593    begin
 594
 595       Res := New_List_Mal_Type (List_Type => L.Get_List_Type);
 596
 597       Old_List := L.The_List;
 598
 599       if Is_Null (Old_List) then
 600          return Res;
 601       end if;
 602
 603       First_New_Node := New_Node_Mal_Type (Func_Ptr.all (Deref_Node (Old_List).Data));
 604
 605       New_List := First_New_Node;
 606
 607       Old_List := Deref_Node (Old_List).Next;
 608
 609       while not Is_Null (Old_List) loop
 610
 611          Deref_Node (New_List).Next :=
 612            New_Node_Mal_Type (Func_Ptr.all (Deref_Node (Old_List).Data));
 613
 614          New_List := Deref_Node (New_List).Next;
 615
 616          Old_List := Deref_Node (Old_List).Next;
 617
 618       end loop;
 619
 620       LP := Deref_List (Res);
 621       LP.The_List := First_New_Node;
 622       LP.Last_Elem := New_List;
 623
 624       return Res;
 625
 626    end Map;
 627
 628
 629    function Reduce
 630      (Func_Ptr : Binary_Func_Access;
 631       L : List_Mal_Type)
 632    return Mal_Handle is
 633
 634       C_Node : Node_Ptr;
 635       Res : Mal_Handle;
 636       use Smart_Pointers;
 637
 638    begin
 639
 640       C_Node := Deref_Node (L.The_List);
 641
 642       if C_Node = null then
 643          return Smart_Pointers.Null_Smart_Pointer;
 644       end if;
 645
 646       Res := C_Node.Data;
 647       while not Is_Null (C_Node.Next) loop
 648          C_Node := Deref_Node (C_Node.Next);
 649          Res := Func_Ptr (Res, C_Node.Data);
 650       end loop;
 651
 652       return Res;
 653
 654    end Reduce;
 655
 656
 657    overriding function To_Str
 658      (T : Node_Mal_Type; Print_Readably : Boolean := True)
 659    return Mal_String is
 660    begin
 661       if Is_Null (T.Data) then
 662          -- Left is null and by implication so is right.
 663          return "";
 664       elsif Is_Null (T.Next) then
 665         -- Left is not null but right is.
 666         return To_Str (Deref (T.Data).all, Print_Readably);
 667       else
 668         -- Left and right are both not null.
 669         return To_Str (Deref (T.Data).all, Print_Readably) &
 670                " " &
 671                To_Str (Deref (T.Next).all, Print_Readably);
 672       end if;
 673    end To_Str;
 674
 675
 676    function Cat_Str (T : Node_Mal_Type; Print_Readably : Boolean := True)
 677    return Mal_String is
 678    begin
 679       if Is_Null (T.Data) then
 680          -- Left is null and by implication so is right.
 681          return "";
 682       elsif Is_Null (T.Next) then
 683         -- Left is not null but right is.
 684         return To_Str (Deref (T.Data).all, Print_Readably);
 685
 686       -- Left and right are both not null.
 687       else
 688         return To_Str (Deref (T.Data).all, Print_Readably) &
 689                Cat_Str (Deref_Node (T.Next).all, Print_Readably);
 690       end if;
 691    end Cat_Str;
 692
 693
 694    function Deref_Node (SP : Mal_Handle) return Node_Ptr is
 695    begin
 696       return Node_Ptr (Deref (SP));
 697    end Deref_Node;
 698
 699
 700    function "=" (A, B : List_Mal_Type) return Boolean is
 701    begin
 702       return Nodes_Equal (A.The_List, B.The_List);
 703    end "=";
 704
 705    function New_List_Mal_Type
 706      (The_List : List_Mal_Type)
 707    return Mal_Handle is
 708    begin
 709      return Smart_Pointers.New_Ptr
 710         (new List_Mal_Type'(Mal_Type with
 711           List_Type => The_List.List_Type,
 712           The_List => The_List.The_List,
 713           Last_Elem => The_List.Last_Elem));
 714    end New_List_Mal_Type;
 715
 716
 717    function New_List_Mal_Type
 718      (List_Type : List_Types;
 719       The_First_Node : Mal_Handle := Smart_Pointers.Null_Smart_Pointer)
 720    return Mal_Handle is
 721    begin
 722       return Smart_Pointers.New_Ptr
 723         (new List_Mal_Type'
 724           (Mal_Type with
 725             List_Type => List_Type,
 726             The_List => The_First_Node,
 727             Last_Elem => The_First_Node));
 728    end New_List_Mal_Type;
 729
 730
 731    function Make_New_List (Handle_List : Handle_Lists) return Mal_Handle is
 732
 733       List_SP : Mal_Handle;
 734       List_P : List_Ptr;
 735
 736    begin
 737       List_SP := New_List_Mal_Type (List_Type => List_List);
 738       List_P := Deref_List (List_SP);
 739       for I in Handle_List'Range loop
 740          Append (List_P.all, Handle_List (I));
 741       end loop;
 742       return List_SP;
 743    end Make_New_List;
 744
 745
 746    overriding function Sym_Type (T : List_Mal_Type) return Sym_Types is
 747    begin
 748       return List;
 749    end Sym_Type;
 750
 751
 752    function Get_List_Type (L : List_Mal_Type) return List_Types is
 753    begin
 754       return L.List_Type;
 755    end Get_List_Type;
 756
 757
 758    function Prepend (Op : Mal_Handle; To_List : List_Mal_Type)
 759    return Mal_Handle is
 760    begin
 761       return New_List_Mal_Type
 762                (List_List,
 763                 New_Node_Mal_Type (Op, To_List.The_List));
 764    end Prepend;
 765
 766
 767    procedure Append (To_List : in out List_Mal_Type; Op : Mal_Handle) is
 768    begin
 769       if Is_Null (Op) then
 770          return;  -- Say what
 771       end if;
 772
 773       -- If the list is null just insert the new element
 774       -- else use the last_elem pointer to insert it and then update it.
 775       if Is_Null (To_List.The_List) then
 776          To_List.The_List := New_Node_Mal_Type (Op);
 777          To_List.Last_Elem := To_List.The_List;
 778       else
 779          Deref_Node (To_List.Last_Elem).Next := New_Node_Mal_Type (Op);
 780          To_List.Last_Elem := Deref_Node (To_List.Last_Elem).Next;
 781       end if;
 782    end Append;
 783
 784
 785    -- Duplicate copies the list (logically).  This is to allow concatenation,
 786    -- The result is always a List_List.
 787    function Duplicate (The_List : List_Mal_Type) return Mal_Handle is
 788       Res, Old_List, First_New_Node, New_List : Mal_Handle;
 789       LP : List_Ptr;
 790    begin
 791
 792       Res := New_List_Mal_Type (List_List);
 793
 794       Old_List := The_List.The_List;
 795
 796       if Is_Null (Old_List) then
 797          return Res;
 798       end if;
 799
 800       First_New_Node := New_Node_Mal_Type (Deref_Node (Old_List).Data);
 801       New_List := First_New_Node;
 802       Old_List := Deref_Node (Old_List).Next;
 803
 804       while not Is_Null (Old_List) loop
 805
 806          Deref_Node (New_List).Next := New_Node_Mal_Type (Deref_Node (Old_List).Data);
 807          New_List := Deref_Node (New_List).Next;
 808          Old_List := Deref_Node (Old_List).Next;
 809
 810       end loop;
 811
 812       LP := Deref_List (Res);
 813       LP.The_List := First_New_Node;
 814       LP.Last_Elem := New_List;
 815
 816       return Res;
 817
 818    end Duplicate;
 819
 820
 821    function Nth (L : List_Mal_Type; N : Natural) return Mal_Handle is
 822
 823       C : Natural;
 824       Next : Mal_Handle;
 825
 826    begin
 827
 828       C := 0;
 829
 830       Next := L.The_List;
 831
 832       while not Is_Null (Next) loop
 833
 834          if C >= N then
 835             return Deref_Node (Next).Data;
 836          end if;
 837
 838          C := C + 1;
 839
 840          Next := Deref_Node (Next).Next;
 841
 842       end loop;
 843
 844       raise Runtime_Exception with "Nth (list): Index out of range";
 845
 846    end Nth;
 847
 848
 849    function Concat (Rest_Handle : List_Mal_Type)
 850    return Types.Mal_Handle is
 851       Rest_List : Types.List_Mal_Type;
 852       List : Types.List_Class_Ptr;
 853       Res_List_Handle, Dup_List : Mal_Handle;
 854       Last_Node_P : Mal_Handle := Smart_Pointers.Null_Smart_Pointer;
 855    begin
 856       Rest_List := Rest_Handle;
 857
 858       -- Set the result to the null list.
 859       Res_List_Handle := New_List_Mal_Type (List_List);
 860
 861       while not Is_Null (Rest_List) loop
 862
 863          -- Find the next list in the list...
 864          List := Deref_List_Class (Car (Rest_List));
 865
 866          -- Duplicate nodes to its contents.
 867          Dup_List := Duplicate (List.all);
 868
 869          -- If we haven't inserted a list yet, then take the duplicated list whole.
 870          if Is_Null (Last_Node_P) then
 871             Res_List_Handle := Dup_List;
 872          else
 873             -- Note that the first inserted list may have been the null list
 874             -- and so may the newly duplicated one...
 875             Deref_Node (Last_Node_P).Next := Deref_List (Dup_List).The_List;
 876             if Is_Null (Deref_List (Res_List_Handle).The_List) then
 877                Deref_List (Res_list_Handle).The_List :=
 878                  Deref_List (Dup_List).The_List;
 879             end if;
 880             if not Is_Null (Deref_List (Dup_List).Last_Elem) then
 881                Deref_List (Res_List_Handle).Last_Elem :=
 882                  Deref_List (Dup_List).Last_Elem;
 883             end if;
 884          end if;
 885
 886          Last_Node_P := Deref_List (Dup_List).Last_Elem;
 887
 888          Rest_List := Deref_List (Cdr (Rest_List)).all;
 889
 890       end loop;
 891
 892       return Res_List_Handle;
 893
 894    end Concat;
 895
 896
 897    procedure Add_Defs (Defs : List_Mal_Type; Env : Envs.Env_Handle) is
 898       D, L : List_Mal_Type;
 899    begin
 900       D := Defs;
 901       while not Is_Null (D) loop
 902          L := Deref_List (Cdr (D)).all;
 903          Envs.Set
 904            (Env,
 905             Deref_Sym (Car (D)).Get_Sym,
 906             Eval_Callback.Eval.all (Car (L), Env));
 907          D := Deref_List (Cdr(L)).all;
 908       end loop;
 909    end Add_Defs;
 910
 911
 912    function Deref_List (SP : Mal_Handle) return List_Ptr is
 913    begin
 914       return List_Ptr (Deref (SP));
 915    end Deref_List;
 916
 917
 918    function Deref_List_Class (SP : Mal_Handle) return List_Class_Ptr is
 919    begin
 920       return List_Class_Ptr (Deref (SP));
 921    end Deref_List_Class;
 922
 923
 924    overriding function To_Str
 925      (T : List_Mal_Type; Print_Readably : Boolean := True)
 926    return Mal_String is
 927    begin
 928       if Is_Null (T.The_List) then
 929          return Opening (T.List_Type) &
 930                 Closing (T.List_Type);
 931       else
 932          return Opening (T.List_Type) &
 933                 To_String (Deref (T.The_List).all, Print_Readably) &
 934                 Closing (T.List_Type);
 935       end if;
 936    end To_Str;
 937
 938
 939    function Pr_Str (T : List_Mal_Type; Print_Readably : Boolean := True)
 940    return Mal_String is
 941    begin
 942       if Is_Null (T.The_List) then
 943          return "";
 944       else
 945          return To_String (Deref_Node (T.The_List).all, Print_Readably);
 946       end if;
 947    end Pr_Str;
 948
 949
 950    function Cat_Str (T : List_Mal_Type; Print_Readably : Boolean := True)
 951    return Mal_String is
 952    begin
 953       if Is_Null (T.The_List) then
 954          return "";
 955       else
 956          return Cat_Str (Deref_Node (T.The_List).all, Print_Readably);
 957       end if;
 958    end Cat_Str;
 959
 960
 961    function Opening (LT : List_Types) return Character is
 962       Res : Character;
 963    begin
 964       case LT is
 965          when List_List =>
 966             Res := '(';
 967          when Vector_List =>
 968             Res := '[';
 969          when Hashed_List =>
 970             Res := '{';
 971       end case;
 972       return Res;
 973    end Opening;
 974
 975
 976    function Closing (LT : List_Types) return Character is
 977       Res : Character;
 978    begin
 979       case LT is
 980          when List_List =>
 981             Res := ')';
 982          when Vector_List =>
 983             Res := ']';
 984          when Hashed_List =>
 985             Res := '}';
 986       end case;
 987       return Res;
 988    end Closing;
 989
 990
 991    function New_Lambda_Mal_Type
 992      (Params : Mal_Handle; Expr : Mal_Handle; Env : Envs.Env_Handle)
 993    return Mal_Handle is
 994    begin
 995       return Smart_Pointers.New_Ptr
 996         (new Lambda_Mal_Type'
 997           (Mal_Type with
 998              Params => Params,
 999              Expr => Expr,
1000              Env => Env,
1001              Is_Macro => False));
1002    end New_Lambda_Mal_Type;
1003
1004    overriding function Sym_Type (T : Lambda_Mal_Type) return Sym_Types is
1005    begin
1006       return Lambda;
1007    end Sym_Type;
1008
1009    function Get_Env (L : Lambda_Mal_Type) return Envs.Env_Handle is
1010    begin
1011       return L.Env;
1012    end Get_Env;
1013
1014    procedure Set_Env (L : in out Lambda_Mal_Type; Env : Envs.Env_Handle) is
1015    begin
1016       L.Env := Env;
1017    end Set_Env;
1018
1019    function Get_Params (L : Lambda_Mal_Type) return Mal_Handle is
1020    begin
1021       if Deref (L.Params).Sym_Type = List and then
1022          Deref_List (L.Params).Get_List_Type = Vector_List then
1023          -- Its a vector and we need a list...
1024          return Deref_List_Class (L.Params).Duplicate;
1025       else
1026          return L.Params;
1027       end if;
1028    end Get_Params;
1029
1030    function Get_Expr (L : Lambda_Mal_Type) return Mal_Handle is
1031    begin
1032       return L.Expr;
1033    end Get_Expr;
1034
1035    function Get_Is_Macro (L : Lambda_Mal_Type) return Boolean is
1036    begin
1037       return L.Is_Macro;
1038    end Get_Is_Macro;
1039
1040    procedure Set_Is_Macro (L : in out Lambda_Mal_Type; B : Boolean) is
1041    begin
1042       L.Is_Macro := B;
1043    end Set_Is_Macro;
1044
1045
1046    function Apply
1047      (L : Lambda_Mal_Type;
1048       Param_List : Mal_Handle)
1049    return Mal_Handle is
1050
1051       E : Envs.Env_Handle;
1052       Param_Names : List_Mal_Type;
1053       Res : Mal_Handle;
1054
1055    begin
1056
1057       E := Envs.New_Env (L.Env);
1058
1059       Param_Names := Deref_List (L.Get_Params).all;
1060
1061       if Envs.Bind (E, Param_Names, Deref_List (Param_List).all) then
1062
1063          Res := Eval_Callback.Eval.all (L.Get_Expr, E);
1064
1065       else
1066
1067          raise Runtime_Exception with "Bind failed in Apply";
1068
1069       end if;
1070
1071       return Res;
1072
1073    end Apply;
1074
1075
1076    function Get_Macro (T : Mal_Handle; Env : Envs.Env_Handle) return Lambda_Ptr is
1077       L : List_Mal_Type;
1078       First_Elem, Func : Mal_Handle;
1079    begin
1080
1081       if Deref (T).Sym_Type /= List then
1082          return null;
1083       end if;
1084
1085       L := Deref_List (T).all;
1086
1087       if Is_Null (L) then
1088          return null;
1089       end if;
1090
1091       First_Elem := Car (L);
1092
1093       if Deref (First_Elem).Sym_Type /= Sym then
1094          return null;
1095       end if;
1096
1097       Func := Envs.Get (Env, Deref_Sym (First_Elem).Get_Sym);
1098
1099       if Deref (Func).Sym_Type /= Lambda then
1100          return null;
1101       end if;
1102
1103       return Deref_Lambda (Func);
1104
1105    exception
1106       when Envs.Not_Found => return null;
1107    end Get_Macro;
1108
1109
1110    overriding function To_Str
1111      (T : Lambda_Mal_Type; Print_Readably : Boolean := True)
1112    return Mal_String is
1113    begin
1114 --      return "(lambda " & Ada.Strings.Unbounded.To_String (T.Rep) & ")";
1115       return "#<function>";
1116    end To_Str;
1117
1118    function Deref_Lambda (SP : Mal_Handle) return Lambda_Ptr is
1119    begin
1120       return Lambda_Ptr (Deref (SP));
1121    end Deref_Lambda;
1122
1123
1124    function Arith_Op (A, B : Mal_Handle) return Mal_Handle is
1125       use Types;
1126       A_Sym_Type : Sym_Types;
1127       B_Sym_Type : Sym_Types;
1128    begin
1129
1130       if Is_Null (A) then
1131         if Is_Null (B) then
1132            -- both null, gotta be zero.
1133            return New_Int_Mal_Type (0);
1134         else  -- A is null but B is not.
1135            return Arith_Op (New_Int_Mal_Type (0), B);
1136         end if;
1137       elsif Is_Null (B) then
1138         -- A is not null but B is.
1139          return Arith_Op (A, New_Int_Mal_Type (0));
1140       end if;
1141
1142       -- else both A and B and not null.:wq
1143       A_Sym_Type := Deref (A).Sym_Type;
1144       B_Sym_Type := Deref (B).Sym_Type;
1145       if A_Sym_Type = Int and B_Sym_Type = Int then
1146          return New_Int_Mal_Type
1147            (Int_Op (Deref_Int (A).Get_Int_Val, Deref_Int (B).Get_Int_Val));
1148       elsif A_Sym_Type = Int and B_Sym_Type = Floating then
1149          return New_Float_Mal_Type
1150            (Float_Op (Mal_Float (Deref_Int (A).Get_Int_Val),
1151             Deref_Float (B).Get_Float_Val));
1152       elsif A_Sym_Type = Floating and B_Sym_Type = Int then
1153          return New_Float_Mal_Type
1154            (Float_Op (Deref_Float (A).Get_Float_Val,
1155             Mal_Float (Deref_Float (B).Get_Float_Val)));
1156       elsif A_Sym_Type = Floating and B_Sym_Type = Floating then
1157          return New_Float_Mal_Type
1158            (Float_Op (Deref_Float (A).Get_Float_Val,
1159             Deref_Float (B).Get_Float_Val));
1160       else
1161          if A_Sym_Type = Error then
1162             return A;
1163          elsif B_Sym_Type = Error then
1164             return B;
1165          else
1166             return New_Error_Mal_Type ("Invalid operands");
1167          end if;
1168       end if;
1169    end Arith_Op;
1170
1171
1172    function Rel_Op (A, B : Mal_Handle) return Mal_Handle is
1173       use Types;
1174       A_Sym_Type : Sym_Types := Deref (A).Sym_Type;
1175       B_Sym_Type : Sym_Types := Deref (B).Sym_Type;
1176    begin
1177       if A_Sym_Type = Int and B_Sym_Type = Int then
1178          return New_Bool_Mal_Type
1179            (Int_Rel_Op (Deref_Int (A).Get_Int_Val, Deref_Int (B).Get_Int_Val));
1180       elsif A_Sym_Type = Int and B_Sym_Type = Floating then
1181          return New_Bool_Mal_Type
1182            (Float_Rel_Op (Mal_Float (Deref_Int (A).Get_Int_Val),
1183             Deref_Float (B).Get_Float_Val));
1184       elsif A_Sym_Type = Floating and B_Sym_Type = Int then
1185          return New_Bool_Mal_Type
1186            (Float_Rel_Op (Deref_Float (A).Get_Float_Val,
1187             Mal_Float (Deref_Float (B).Get_Float_Val)));
1188       else
1189          return New_Bool_Mal_Type
1190            (Float_Rel_Op (Deref_Float (A).Get_Float_Val,
1191             Deref_Float (B).Get_Float_Val));
1192       end if;
1193    end Rel_Op;
1194
1195
1196 end Types;