DataMuseum.dk Presents historical artifacts from the history of: Rational R1000/400

This is an automatic "excavation" of a thematic subset of artifacts from Datamuseum.dk's BitArchive. See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software.

top - download

⟦18f2a4073⟧ Ada Source

    Length: 10240 (0x2800)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Action_List, seg_04560d

Derivation

└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
    └─ ⟦5a81ac88f⟧ »Space Info Vol 1« 
        └─⟦this⟧ 

with Stack_Generic, Text_Io, Compiler_Action;
package body Action_List is

    type Context_Backup is
        record
            Action_List : Compiler_Action.Acces_List;  
            Action : Compiler_Action.Object;
        end record;

    package Context_Stack is new Stack_Generic (Context_Backup);

    Master_List : Compiler_Action.Acces_List;
    Current_Context : Context_Backup;
    Save_Stack : Context_Stack.Stack;

    The_End : Boolean;

    procedure Initialize is

    begin
        The_End := False;
        Compiler_Action.Create_List (Master_List);
        Current_Context.Action_List := Master_List;
    end Initialize;

    procedure Create_If is
        Temp_Action : Compiler_Action.Object;
    begin
        Compiler_Action.Create_Action (Temp_Action,
                                       Compiler_Action.Conditional_Action);
        Current_Context.Action := Temp_Action;
        Context_Stack.Push (Current_Context, Save_Stack);
    end Create_If;

    procedure Set_Condition (C : Dynamic_Node.Object) is  
        Temp_Context : Context_Backup;
    begin  
        Temp_Context := Context_Stack.Top (Save_Stack);
        Compiler_Action.Set_Argument (Temp_Context.Action,
                                      Compiler_Action.Condition_Argument, C);  
    end Set_Condition;

    procedure Go_In_Then is  
        Temp_Context : Context_Backup;
    begin
        Temp_Context := Context_Stack.Top (Save_Stack);  
        Current_Context.Action_List :=
           Compiler_Action.Get_True_Bloc (Temp_Context.Action);
    end Go_In_Then;


    procedure Go_In_Else is
        Temp_Context : Context_Backup;
    begin
        Temp_Context := Context_Stack.Top (Save_Stack);
        Current_Context.Action_List :=
           Compiler_Action.Get_False_Bloc (Temp_Context.Action);
    end Go_In_Else;


    procedure End_Of_If is
    begin  
        Current_Context := Context_Stack.Top (Save_Stack);
        Context_Stack.Pop (Save_Stack);
        Compiler_Action.Add_Action
           (Current_Context.Action_List, Current_Context.Action);
    end End_Of_If;


    procedure Create (With_Kind : Simple_Action) is   -- changement
        Temp_Action : Compiler_Action.Object;
    begin  
        case With_Kind is
            when Write_Action =>
                Compiler_Action.Create_Action (Temp_Action,
                                               Compiler_Action.Write_Action);

            when Affect_Action =>
                Compiler_Action.Create_Action (Temp_Action,
                                               Compiler_Action.Affect_Action);
            when Append_In_Set_Of_Word =>
                Compiler_Action.Create_Action
                   (Temp_Action, Compiler_Action.Append_In_Set_Of_Word);
                Compiler_Action.Print_Action (Temp_Action);
            when Remove_From_Set_Of_Word =>
                Compiler_Action.Create_Action
                   (Temp_Action, Compiler_Action.Remove_From_Set_Of_Word);
                Compiler_Action.Print_Action (Temp_Action);
            when Clear_Set_Of_Word =>
                Compiler_Action.Create_Action
                   (Temp_Action, Compiler_Action.Clear_Set_Of_Word);
                Compiler_Action.Print_Action (Temp_Action);
            when Quit_Action =>
                null;
            when others =>
                null;
        end case;
        Current_Context.Action := Temp_Action;
        Compiler_Action.Add_Action
           (Current_Context.Action_List, Current_Context.Action);
    end Create;


    procedure Append_Argument (The_Argument : Dynamic_Node.Object) is
    begin
        case Compiler_Action.Get_Kind (Current_Context.Action) is
            when Compiler_Action.Write_Action =>
                Compiler_Action.Set_Argument
                   (Current_Context.Action,
                    Compiler_Action.Write_Argument, The_Argument);
            when others =>
                null;
        end case;
    end Append_Argument;

    procedure Set_Argument (The_Argument : Dynamic_Node.Object;
                            In_Position : Position) is

    begin
        case Compiler_Action.Get_Kind (Current_Context.Action) is  
            when Compiler_Action.Affect_Action =>
                if In_Position = Source then
                    Compiler_Action.Set_Argument
                       (Current_Context.Action,
                        Compiler_Action.Source_Argument, The_Argument);
                else
                    Compiler_Action.Set_Argument
                       (Current_Context.Action,
                        Compiler_Action.Target_Argument, The_Argument);  
                end if;
            when Compiler_Action.Append_In_Set_Of_Word =>
                if In_Position = Source then
                    Compiler_Action.Set_Argument
                       (Current_Context.Action,
                        Compiler_Action.Source_Argument, The_Argument);
                else
                    Compiler_Action.Set_Argument
                       (Current_Context.Action,
                        Compiler_Action.Target_Argument, The_Argument);
                end if;
            when Compiler_Action.Remove_From_Set_Of_Word =>
                if In_Position = Source then
                    Compiler_Action.Set_Argument
                       (Current_Context.Action,
                        Compiler_Action.Source_Argument, The_Argument);
                else
                    Compiler_Action.Set_Argument
                       (Current_Context.Action,
                        Compiler_Action.Target_Argument, The_Argument);
                end if;
            when Compiler_Action.Clear_Set_Of_Word =>
                if In_Position = Target then
                    Compiler_Action.Set_Argument
                       (Current_Context.Action,
                        Compiler_Action.Target_Argument, The_Argument);  
                end if;
            when others =>
                null;
        end case;
    end Set_Argument;

    procedure Evaluate is

    begin
        Compiler_Action.Evaluate (Master_List);
    end Evaluate;

    procedure Execute is

    begin
        Compiler_Action.Execute (Master_List);
    exception
        when Compiler_Action.End_Of_Program =>
            The_End := True;
    end Execute;

    function Is_End return Boolean is  
    begin
        return The_End;
    end Is_End;

end Action_List;

    nblk1=9
    nid=0
    hdr6=12
        [0x00] rec0=21 rec1=00 rec2=01 rec3=06a
        [0x01] rec0=03 rec1=00 rec2=04 rec3=02c
        [0x02] rec0=1d rec1=00 rec2=02 rec3=042
        [0x03] rec0=17 rec1=00 rec2=06 rec3=044
        [0x04] rec0=18 rec1=00 rec2=07 rec3=022
        [0x05] rec0=06 rec1=00 rec2=09 rec3=042
        [0x06] rec0=16 rec1=00 rec2=03 rec3=004
        [0x07] rec0=17 rec1=00 rec2=08 rec3=00a
        [0x08] rec0=15 rec1=00 rec2=05 rec3=000
    tail 0x21541b354864a8ec6c540 0x42a00088462060003