Version V2p0r of ee9 for Windows, built on Wed Oct 28 18:13:19 GMTST 2015
mk9 'ee9' build: optimised and with runtime checking, using configuration options:

pragma Assertion_Policy(Ignore);
pragma Unsuppress(All_Checks);
pragma Validity_Checks(Off);
pragma Warnings(On);
pragma Optimize_Alignment(Time);
pragma Restrictions(Max_Asynchronous_Select_Nesting => 0);
pragma Restrictions(Max_Tasks => 0);
pragma Restrictions(No_Abort_Statements);

Using the build command:
gnatmake -fstack-check -j1 -aI../Source -aO../Build -funwind-tables -g -gnatfl12j96 -gnatw.e -gnatwD -gnatwH -gnatwP -gnatwT -gnatw.W -gnatw.B -gnatwC -gnatw.u -gnatyO -gnatw.Y -gnatn -falign-loops=8 -funroll-loops -fsched-interblock -fomit-frame-pointer -fno-stack-check -O3 ee9 -largs ./get_O_BINARY.o -bargs -static

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ee9.adb
Source file time stamp: 2015-06-18 00:56:56
Compiled at: 2015-10-28 18:13:22

     1. -- ee9.adb
     2. --
     3. -- This is the "main program" co-ordinate module for the entire emulator.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Command_Line;
    20. with Ada.Exceptions;
    21. --
    22. with exceptions;
    23. with execute;
    24. with HCI;
    25. with settings;
    26. with toggle_the_shared_buffer;
    27.
    28. use  exceptions;
    29. use  HCI;
    30. use  settings;
    31.
    32. procedure ee9 is
    33.
    34.    pragma Unsuppress(All_Checks);
    35.
    36.    package CLI renames Ada.Command_Line;
    37.
    38.    the_log_file_name : constant String := "KDF9_log.txt";
    39.
    40.    a_command_line_error_was_detected : exception;
    41.
    42.    procedure show_proper_usage (message : in String := "") is
    43.    begin
    44.       if message /= "" then
    45.          log_line(message);
    46.       end if;
    47.       log_line("usage: ee9 { -s{b|p|t} | -d{f|p|t|x} | -m"
    48.              & miscellany_prompt
    49.              & " } program_file_name");
    50.       CLI.Set_Exit_Status(CLI.Failure);
    51.       raise a_command_line_error_was_detected;
    52.    end show_proper_usage;
    53.
    54.    procedure complain (about : in String) is
    55.    begin
    56.       show_proper_usage("Parameter " & about & " is not valid!");
    57.    end complain;
    58.
    59.    procedure check_all_flag_settings is
    60.
    61.       procedure check_flag_setting (i : in Positive) is
    62.          argument : constant String := CLI.Argument(i);
    63.       begin
    64.          -- Fail an empty parameter.
    65.          if argument'Length = 0 then
    66.             complain(about => "number" & Positive'Image(i) & " being empty");
    67.          end if;
    68.
    69.          -- Ignore a program_file_name parameter.
    70.          if argument(argument'First) /= '-'  then
    71.             return;
    72.          end if;
    73.
    74.          -- Fail a too-short flag parameter.
    75.          if argument'Length = 2  and then
    76.                argument = "-m"       then
    77.             return;
    78.          end if;
    79.          if argument'Length < 3 then
    80.             complain(about => "'" & argument & "'");
    81.          end if;
    82.
    83.          -- Check for a miscellany parameter.
    84.          if argument'Length in 2 .. miscellany_flags'Length+2 and then
    85.                argument(argument'First..argument'First+1) = "-m"  then
    86.             for i in argument'First+2 .. argument'Last loop
    87.                if is_invalid_miscellany_flag(argument(i)) then
    88.                   complain(about => "'" & argument & "'" & " at '" & argument(i) & "'");
    89.                end if;
    90.             end loop;
    91.             return;
    92.          end if;
    93.
    94.          -- Check for a state or diagnostic parameter.
    95.          if argument'Length = 3                and then
    96.               (argument = "-sb"                 or else
    97.                   argument = "-sp"              or else
    98.                      argument = "-st"           or else
    99.                         argument = "-df"        or else
   100.                            argument = "-dt"     or else
   101.                               argument = "-dp"  or else
   102.                                  argument = "-dx") then
   103.             return;
   104.          else
   105.             complain(about => "'" & argument & "'");
   106.          end if;
   107.       end check_flag_setting;
   108.
   109.    begin -- check_all_flag_settings
   110.       if CLI.Argument_Count = 0 then
   111.          return;
   112.       end if;
   113.       for i in 1..CLI.Argument_Count loop
   114.          check_flag_setting(i);
   115.       end loop;
   116.    end check_all_flag_settings;
   117.
   118.    procedure impose_all_flag_settings is
   119.
   120.       procedure impose_flag_setting (i : in Positive) is
   121.          argument : constant String := CLI.Argument(i);
   122.       begin
   123.          -- Assume the argument is valid.
   124.
   125.          -- Ignore a program_file_name parameter.
   126.          if argument(argument'First) /= '-'  then
   127.             return;
   128.          end if;
   129.
   130.          -- Impose a miscellany parameter.
   131.          if argument'Length in 2 .. miscellany_flags'Length+2 and then
   132.                argument(argument'First..argument'First+1) = "-m"  then
   133.             for i in argument'First+2 .. argument'Last loop
   134.                set_this_miscellany_flag(argument(i));
   135.             end loop;
   136.             return;
   137.          end if;
   138.
   139.          -- Impose a state or diagnostic parameter.
   140.          if    argument = "-sb" then
   141.             set_execution_mode(boot_mode);
   142.          elsif argument = "-sp" then
   143.             set_execution_mode(program_mode);
   144.          elsif argument = "-st" then
   145.             set_execution_mode(test_program_mode);
   146.          elsif argument = "-df" then
   147.             set_diagnostic_mode(fast_mode);
   148.          elsif argument = "-dt" then
   149.             set_diagnostic_mode(trace_mode);
   150.          elsif argument = "-dp" then
   151.             set_diagnostic_mode(pause_mode);
   152.          elsif argument = "-dx" then
   153.             set_diagnostic_mode(external_mode);
   154.          end if;
   155.       end impose_flag_setting;
   156.
   157.    begin -- impose_all_flag_settings
   158.       if CLI.Argument_Count = 0 then
   159.          return;
   160.       end if;
   161.       for i in 1..CLI.Argument_Count loop
   162.          impose_flag_setting(i);
   163.       end loop;
   164.    end impose_all_flag_settings;
   165.
   166. begin
   167.
   168.    open(the_log_file_name);
   169.
   170.    log_line("Welcome to ee9 V2.0r, the GNU Ada KDF9 emulator.", iff => the_log_is_wanted);
   171.
   172.    check_all_flag_settings;
   173.
   174.    get_settings_from_file("1");
   175.
   176.    impose_all_flag_settings;
   177.
   178.    toggle_the_shared_buffer;
   179.
   180.    display_execution_modes;
   181.
   182.    execute;
   183.
   184.    log_rule(iff => the_log_is_wanted);
   185.
   186.    close(the_log_file_name);
   187.
   188. exception
   189.
   190.    when quit_request =>
   191.       close(the_log_file_name);
   192.
   193.    when a_command_line_error_was_detected =>
   194.       close(the_log_file_name);
   195.
   196.    when error : others =>
   197.       log_new_line;
   198.       log_line("Failure in ee9; unexpected exception: "
   199.              & Ada.Exceptions.Exception_Information(error)
   200.              & " was raised!");
   201.       close(the_log_file_name);
   202.
   203. end ee9;

 203 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\exceptions.ads
Source file time stamp: 2015-06-18 00:56:56
Compiled at: 2015-10-28 18:13:24

     1. -- exceptions.ads
     2. --
     3. -- Declare the exceptions used in emulation-mode control.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package exceptions is
    20.
    21.    -- program_exit is raised when a KDF9 program terminates.
    22.    program_exit        : exception;
    23.
    24.    -- time_expired is raised when a KDF9 program executes too many instructions.
    25.    time_expired        : exception;
    26.
    27.    -- NYI_trap is raised by a KDF9 feature that is Not Yet Implemented.
    28.    NYI_trap            : exception;
    29.
    30.    -- emulation_failure is raised when the emulator discovers it has gone wrong.
    31.    emulation_failure   : exception;
    32.
    33.    -- Director_failure is raised when a failure is detected in Director mode.
    34.    Director_failure    : exception;
    35.
    36.    -- quit_request is raised when the user requests a quit at a break-in.
    37.    quit_request        : exception;
    38.
    39.    -- input_is_impossible is raised when an attempt is made to read from the terminal in
    40.    --    noninteractive mode.  This prevents absent-user scripted usage from hanging.
    41.    input_is_impossible : exception;
    42.
    43. end exceptions;

 43 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\execute.adb
Source file time stamp: 2015-06-18 00:56:54
Compiled at: 2015-10-28 18:13:24

     1. -- execute.adb
     2. --
     3. -- This is the emulation-mode coordinate module.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with GNAT.Ctrl_C;
    20. --
    21. with Ada.Command_Line;
    22. with Ada.Exceptions;
    23. --
    24. with configuration;
    25. with exceptions;
    26. with HCI;
    27. with IOC;
    28. with IOC.two_shift.TR;
    29. with KDF9;
    30. with KDF9.microcode;
    31. with KDF9.store;
    32. with map_CTRL_C_to_FLEX;
    33. with finalize_ee9;
    34. with settings;
    35. with state_display;
    36.
    37. use  Ada.Command_Line;
    38. --
    39. use  exceptions;
    40. use  HCI;
    41. use  IOC;
    42. use  IOC.two_shift.TR;
    43. use  KDF9;
    44. use  KDF9.microcode;
    45. use  KDF9.store;
    46. use  settings;
    47. use  state_display;
    48.
    49. procedure execute is
    50.
    51.    pragma Unsuppress(All_Checks);
    52.
    53.    procedure check_times_and_modes;
    54.    pragma Inline(check_times_and_modes);
    55.
    56.    pause_count : KDF9.order_counter := 0;
    57.
    58.    procedure check_times_and_modes is
    59.    begin
    60.       if ICR > pause_count then
    61.          if ICR >= time_limit then
    62.             raise time_expired;
    63.          end if;
    64.          pause_count := pause_count + time_slice;
    65.          change_diagnostic_mode_if_requested;
    66.       end if;
    67.    end check_times_and_modes;
    68.
    69.    procedure make_a_dignified_exit (status : in Exit_Status := Failure) is
    70.    begin
    71.       finalize_ee9;
    72.       Set_Exit_Status(status);
    73.    exception
    74.       when error : others =>
    75.          log_line("Failure in ee9: "
    76.                 & Ada.Exceptions.Exception_Information(error)
    77.                 & " was raised in 'make_a_dignified_exit'!");
    78.          Set_Exit_Status(Failure);
    79.    end make_a_dignified_exit;
    80.
    81. begin
    82.    GNAT.Ctrl_C.Install_Handler(map_CTRL_C_to_FLEX'Access);
    83.
    84.    if the_external_trace_is_enabled then
    85.       log_an_external_trace_header;
    86.    end if;
    87.
    88.    reset_the_internal_registers;
    89.
    90.    case the_execution_mode is
    91.       when boot_mode =>
    92.          bootstrap_the_KDF9;
    93.       when program_mode =>
    94.          load_a_program;
    95.       when test_program_mode =>
    96.          load_a_program;
    97.    end case;
    98.
    99.    show_all_prerun_dump_areas;
   100.
   101.    reset_the_CPU_state;
   102.
   103.    loop
   104.       begin
   105.          check_times_and_modes;
   106.          if the_diagnostic_mode /= fast_mode then
   107.             -- Do a single, traced instruction, breaking-in conditionally.
   108.             do_a_traced_instruction_cycle;
   109.          else
   110.             -- Fast mode is designed for minimal overhead;
   111.             --    it interacts with the user only at the end of a time slice.
   112.             loop
   113.                do_a_fast_time_slice;
   114.                check_times_and_modes;
   115.             end loop;
   116.          end if;
   117.       exception
   118.          when mode_change_request =>
   119.             quit_if_requested;
   120.          when LOV_trap =>
   121.             IOC.handle_a_main_store_lockout(the_locked_out_address);
   122.       end;
   123.    end loop;
   124.
   125. exception
   126.
   127.    when program_exit =>
   128.       make_a_dignified_exit(Success);
   129.
   130.    when quit_request =>
   131.       log_new_line;
   132.       log_line("Run stopped by the user.");
   133.       make_a_dignified_exit(Success);
   134.
   135.    when time_expired =>
   136.       log_new_line;
   137.       log_line("Run terminated on reaching time limit! Infinite loop?");
   138.       make_a_dignified_exit;
   139.
   140.    when NYI_trap =>
   141.       log_new_line;
   142.       log_line("Instruction Not Yet Implemented!");
   143.       make_a_dignified_exit;
   144.
   145.    when NOUV_trap =>
   146.       log_new_line;
   147.       log_line("NOUV (NEST/SJNS Overflow/Underflow Violation)!");
   148.       make_a_dignified_exit;
   149.
   150.    when error : LIV_trap =>
   151.       log_new_line;
   152.       log_line("LIV (Lock-In Violation)! "
   153.              & Ada.Exceptions.Exception_Message(error));
   154.       make_a_dignified_exit;
   155.
   156.    when RESET_trap =>
   157.       log_new_line;
   158.       log_line("RESET (Reset Violation)!");
   159.       make_a_dignified_exit;
   160.
   161.    when error : Director_failure =>
   162.       log_new_line;
   163.       log_line("Failure detected in Director! "
   164.              & Ada.Exceptions.Exception_Information(error));
   165.       make_a_dignified_exit;
   166.
   167.    when error : input_is_impossible =>
   168.       log_new_line;
   169.       log_line("Noninteractive mode; "
   170.              & Ada.Exceptions.Exception_Message(error));
   171.       make_a_dignified_exit;
   172.
   173.    when error : others =>
   174.       log_new_line;
   175.       log_line("Failure in ee9! "
   176.              & Ada.Exceptions.Exception_Information(error));
   177.       make_a_dignified_exit;
   178.
   179. end execute;

Compiling: ../Source\execute.ads
Source file time stamp: 2015-06-18 00:56:54
Compiled at: 2015-10-28 18:13:24

     1. -- execute.ads
     2. --
     3. -- This is the emulation-mode coordinate module.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. procedure execute;

 179 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\hci.adb
Source file time stamp: 2015-06-18 00:56:42
Compiled at: 2015-10-28 18:13:26

     1. -- HCI.adb
     2. --
     3. -- Provide operations supporting replicated human-readable output:
     4. --    1: to an interactive user interface for transient display, and
     5. --    2: to a file for persistent storage.
     6. -- If no file has been opened, or if it has been explicitly closed,
     7. --    output is to the interactive interface only.
     8. --
     9. -- Also provide operations allowing synchronization with the user.
    10. --
    11. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
    12. -- Copyright (C) 2015, W. Findlay; all rights reserved.
    13. --
    14. -- The ee9 program is free software; you can redistribute it and/or
    15. -- modify it under terms of the GNU General Public License as published
    16. -- by the Free Software Foundation; either version 3, or (at your option)
    17. -- any later version. This program is distributed in the hope that it
    18. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    19. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    20. -- See the GNU General Public License for more details. You should have
    21. -- received a copy of the GNU General Public License distributed with
    22. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    23. --
    24.
    25. with formatting;
    26. with generic_logger; pragma Elaborate_All(generic_logger);
    27. with Latin_1;
    28. with settings;
    29.
    30. use  formatting;
    31. use  Latin_1;
    32. use  settings;
    33.
    34. package body HCI is
    35.
    36.    pragma Unsuppress(All_Checks);
    37.
    38.    package log_manager is new generic_logger(max_logger_list_size => 2);
    39.
    40.    cc_list : log_manager.replicator;
    41.
    42.    procedure tab_log (at_least : in Natural;
    43.                       spacing  : in Positive := 6;
    44.                       iff      : in Boolean := True) is
    45.    begin
    46.       cc_list.tab_log(at_least, spacing, iff);
    47.    end tab_log;
    48.
    49.    procedure tab_log_to (column : in Positive;
    50.                          iff    : in Boolean := True) is
    51.    begin
    52.       cc_list.tab_log_to(column, iff);
    53.    end tab_log_to;
    54.
    55.    procedure log (char : in Character;
    56.                   iff  : in Boolean := True) is
    57.    begin
    58.       cc_list.log(char, iff);
    59.    end log;
    60.
    61.    procedure log (text : in String;
    62.                   iff  : in Boolean := True) is
    63.    begin
    64.       cc_list.log(text, iff);
    65.    end log;
    66.
    67.    procedure log_line (text : in String;
    68.                        iff  : in Boolean := True) is
    69.    begin
    70.       if text /= "" then
    71.          cc_list.log(text, iff);
    72.       end if;
    73.       log_new_line(iff);
    74.    end log_line;
    75.
    76.    procedure log_padded_string (text  : in String;
    77.                                 width : in Positive := 1) is
    78.       pad_width   : constant Natural := Integer'Max (0, width - text'Length);
    79.       padding     : constant String (1 .. pad_width) := (others => ' ');
    80.       padded_text : constant String := padding & text;
    81.    begin
    82.       cc_list.log(padded_text);
    83.    end log_padded_string;
    84.
    85.    procedure log_octal (number : in KDF9.field_of_16_bits;
    86.                         width  : in Positive := 1) is
    87.    begin
    88.       log_padded_string("#" & oct_of(number), width);
    89.    end log_octal;
    90.
    91.    procedure log_octal (number : in KDF9.word;
    92.                         width  : in Positive := 1) is
    93.    begin
    94.       log_padded_string("#" & oct_of(number), width);
    95.    end log_octal;
    96.
    97.    procedure log_new_line (iff : in Boolean := True) is
    98.    begin
    99.       cc_list.log_new_line(iff);
   100.    end log_new_line;
   101.
   102.    half_ruler : constant String (1 .. 36) := (others => '_');
   103.    half_blank : constant String (1 .. 36) := (others => ' ');
   104.    full_ruler : constant String (1 .. 72) := half_ruler & half_ruler;
   105.
   106.    procedure log_rule (start_a_new_line : in Boolean := False;
   107.                        iff              : in Boolean := True) is
   108.    begin
   109.       if start_a_new_line then
   110.          cc_list.log_new_line(iff);
   111.       end if;
   112.       log_line(full_ruler, iff);
   113.    end log_rule;
   114.
   115.    procedure log_rule_half (second_half : in Boolean := False) is
   116.    begin
   117.       if second_half then
   118.          log(half_blank);
   119.       end if;
   120.       log_line(half_ruler);
   121.    end log_rule_half;
   122.
   123.    procedure log_message (message : in String) is
   124.    begin
   125.       cc_list.log(message);
   126.       cc_list.log_new_line;
   127.    end log_message;
   128.
   129.    procedure log_title (message : in String) is
   130.    begin
   131.       cc_list.log_new_line;
   132.       cc_list.log(message);
   133.       cc_list.log_new_line;
   134.    end log_title;
   135.
   136.    procedure log_error_message (message : in String) is
   137.    begin
   138.       log_line("Error: " & message);
   139.    end log_error_message;
   140.
   141.    procedure log_ee9_status (message  : in String;
   142.                              skip     : in Natural := 1;
   143.                              complete : in Boolean := True;
   144.                              iff      : in Boolean := True) is
   145.    begin
   146.       if not iff then return; end if;
   147.       for i in 1 .. skip loop
   148.          log_new_line;
   149.       end loop;
   150.       if complete then
   151.          log_line("ee9: " & message & ".");
   152.       else
   153.          log("ee9: " & message);
   154.       end if;
   155.    end log_ee9_status;
   156.
   157.    procedure hoot (message : in String := "") is
   158.    begin
   159.       panel_logger.log(message & BEL);
   160.    end hoot;
   161.
   162.    procedure show (message : in String) is
   163.    begin
   164.       if debugging_is_enabled then
   165.          panel_logger.show(message);
   166.          flush;
   167.       end if;
   168.    end show;
   169.
   170.    procedure show_line (message : in String) is
   171.    begin
   172.       if debugging_is_enabled then
   173.          panel_logger.show_line(message);
   174.          flush;
   175.       end if;
   176.    end show_line;
   177.
   178.    procedure respond_to_prompt (prompt   : in String;
   179.                                 response : out Character) is
   180.    begin
   181.       panel_logger.respond_to_prompt(prompt, response);
   182.    end respond_to_prompt;
   183.
   184.    procedure continue_when_GO_is_pressed (caption : in String := "") is
   185.    begin
   186.       panel_logger.continue_when_GO_is_pressed(caption);
   187.    end continue_when_GO_is_pressed;
   188.
   189.    procedure open (logfile_name : in String) is
   190.    begin
   191.       cc_list.open(logfile_name);
   192.    end open;
   193.
   194.    procedure close (logfile_name : in String) is
   195.    begin
   196.       cc_list.close(logfile_name);
   197.    end close;
   198.
   199.    procedure flush (iff : in Boolean := True) is
   200.    begin
   201.       cc_list.flush(iff);
   202.    end flush;
   203.
   204.    procedure log_to_file (message : in String) is
   205.    begin
   206.       file_logger.log(message);
   207.       file_logger.log_new_line;
   208.    end log_to_file;
   209.
   210. begin
   211.    cc_list.set_logger_list((file_logger'Access, panel_logger'Access));
   212. end HCI;

Compiling: ../Source\hci.ads
Source file time stamp: 2015-06-18 00:56:40
Compiled at: 2015-10-28 18:13:26

     1. -- HCI.ads
     2. --
     3. -- Provide operations supporting replicated human-readable output:
     4. --    1: to an interactive user interface for transient display, and
     5. --    2: to a file for persistent storage.
     6. -- If no file has been opened, or if it has been explicitly closed,
     7. --    output is to the interactive interface only.
     8. --
     9. -- Also provide operations allowing synchronization with the user.
    10. --
    11. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
    12. -- Copyright (C) 2015, W. Findlay; all rights reserved.
    13. --
    14. -- The ee9 program is free software; you can redistribute it and/or
    15. -- modify it under terms of the GNU General Public License as published
    16. -- by the Free Software Foundation; either version 3, or (at your option)
    17. -- any later version. This program is distributed in the hope that it
    18. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    19. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    20. -- See the GNU General Public License for more details. You should have
    21. -- received a copy of the GNU General Public License distributed with
    22. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    23. --
    24.
    25. with KDF9;
    26. with logging.file;
    27. with logging.panel;
    28.
    29. use  KDF9;
    30. use  logging.file;
    31. use  logging.panel;
    32.
    33. package HCI is
    34.
    35.    pragma Unsuppress(All_Checks);
    36.
    37.    file_logger  : aliased logging.file.output;
    38.    panel_logger : aliased logging.panel.display;
    39.
    40.    procedure tab_log (at_least : in Natural;
    41.                       spacing  : in Positive := 6;
    42.                       iff      : in Boolean := True);
    43.
    44.    procedure tab_log_to (column : in Positive;
    45.                          iff    : in Boolean := True);
    46.
    47.    procedure log (char : in Character;
    48.                   iff  : in Boolean := True);
    49.
    50.    procedure log (text : in String;
    51.                   iff  : in Boolean := True);
    52.
    53.    procedure log_line (text : in String;
    54.                        iff  : in Boolean := True);
    55.
    56.    -- Log in octal with initial '#'.
    57.    procedure log_octal (number : in KDF9.word;
    58.                         width  : in Positive := 1);
    59.
    60.    procedure log_octal (number : in KDF9.field_of_16_bits;
    61.                         width  : in Positive := 1);
    62.
    63.    procedure log_new_line (iff : in Boolean := True);
    64.
    65.    procedure log_rule (start_a_new_line : in Boolean := False;
    66.                        iff              : in Boolean := True);
    67.
    68.    procedure log_rule_half (second_half : in Boolean := False);
    69.
    70.    procedure log_message (message : in String);
    71.
    72.    procedure log_error_message (message : in String);
    73.
    74.    procedure log_title (message : in String);
    75.
    76.    procedure log_ee9_status (message  : in String;
    77.                              skip     : in Natural := 1;
    78.                              complete : in Boolean := True;
    79.                              iff      : in Boolean := True);
    80.
    81.    procedure hoot (message : in String := "");
    82.
    83.    procedure show (message : in String);
    84.
    85.    procedure show_line (message : in String);
    86.
    87.    procedure respond_to_prompt (prompt   : in String;
    88.                                 response : out Character);
    89.
    90.    procedure continue_when_GO_is_pressed (caption  : in String := "");
    91.
    92.    procedure open  (logfile_name : in String);
    93.
    94.    procedure close (logfile_name : in String);
    95.
    96.    procedure flush (iff : in Boolean := True);
    97.
    98.    procedure log_to_file (message : in String);
    99.
   100. end HCI;

 212 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\settings.adb
Source file time stamp: 2015-06-18 00:55:42
Compiled at: 2015-10-28 18:13:29

     1. -- settings.adb
     2. --
     3. -- execution mode, diagnostic mode, and other emulation-control settings
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Exceptions;
    20. with Ada.Text_IO;
    21. --
    22. with dumping;
    23. with exceptions;
    24. with formatting;
    25. with HCI;
    26. with KDF9.store;
    27. with postscript;
    28. with settings.IO;
    29. with tracing;
    30.
    31. use  Ada.Text_IO;
    32. --
    33. use  dumping;
    34. use  exceptions;
    35. use  formatting;
    36. use  HCI;
    37. use  KDF9.store;
    38. use  settings.IO;
    39. use  tracing;
    40.
    41. package body settings is
    42.
    43.    pragma Unsuppress(All_Checks);
    44.
    45.    function is_invalid_miscellany_flag (option : in Character)
    46.    return Boolean is
    47.    begin
    48.       for i in miscellany_flags'Range loop
    49.          if miscellany_flags(i) = option then
    50.             return False;
    51.          end if;
    52.       end loop;
    53.       return True;
    54.    end is_invalid_miscellany_flag;
    55.
    56.    procedure set_this_miscellany_flag (option : in Character) is
    57.    begin
    58.       if is_invalid_miscellany_flag(option) then
    59.          log_line("***** Error in a miscellany specification: '"
    60.                 & option
    61.                 & "'.");
    62.          return;
    63.       end if;
    64.       case option is
    65.          when '1' .. '9' =>
    66.             time_limit := (Character'Pos(option) - Character'Pos('0')) * 10_000_000;
    67.          when 'a' =>
    68.             API_logging_is_requested := False;
    69.          when 'd' =>
    70.             debugging_is_enabled := True;
    71.          when 'e' =>
    72.             the_log_is_wanted := False;
    73.          when 'f' =>
    74.             the_final_state_is_wanted := False;
    75.          when 'g' =>
    76.             the_graph_plotter_is_configured := True;
    77.          when 'h' =>
    78.             the_histogram_is_requested := False;
    79.          when 'i' =>
    80.             interrupt_tracing_is_requested := False;
    81.          when 'l' =>
    82.             time_limit := offline_time_limit;
    83.          when 'n' =>
    84.             noninteractive_usage_is_enabled := True;
    85.             time_limit := offline_time_limit;
    86.          when 'p' =>
    87.             peripheral_tracing_is_requested := False;
    88.          when 'r' =>
    89.             retrospective_tracing_is_requested := False;
    90.          when 's' =>
    91.             the_signature_is_requested := False;
    92.          when 't' =>
    93.             authentic_timing_is_wanted := True;
    94.          when 'z' =>
    95.             API_logging_is_requested := False;
    96.             debugging_is_enabled := False;
    97.             the_log_is_wanted := False;
    98.             the_final_state_is_wanted := False;
    99.             the_histogram_is_requested := False;
   100.             interrupt_tracing_is_requested := False;
   101.             peripheral_tracing_is_requested := False;
   102.             retrospective_tracing_is_requested := False;
   103.             the_signature_is_requested := False;
   104.          when others =>
   105.             raise emulation_failure;
   106.       end case;
   107.       set_diagnostic_mode(the_diagnostic_mode);
   108.    end set_this_miscellany_flag;
   109.
   110.    procedure display_execution_modes is
   111.       needs_comma : Boolean := False;
   112.
   113.       procedure append_option (flag : in Boolean; name : in String) is
   114.       begin
   115.          if flag then
   116.             if needs_comma then
   117.                log(", ");
   118.             end if;
   119.             log(name);
   120.             needs_comma := True;
   121.          end if;
   122.       end append_option;
   123.
   124.    begin
   125.       if not the_log_is_wanted then return; end if;
   126.       case the_execution_mode is
   127.          when boot_mode =>
   128.             log("Performing a cold boot in ");
   129.          when program_mode =>
   130.             log("Running a problem program in ");
   131.          when test_program_mode =>
   132.             log("Running a test program in ");
   133.       end case;
   134.       if authentic_timing_is_wanted then
   135.          log("real time ");
   136.       end if;
   137.       case the_diagnostic_mode is
   138.          when fast_mode =>
   139.             log("fast mode (without diagnostics)");
   140.          when trace_mode =>
   141.             if the_external_trace_is_enabled then
   142.                log("external trace mode");
   143.             else
   144.                log("trace mode");
   145.             end if;
   146.          when pause_mode =>
   147.             log("pause mode");
   148.          when external_mode =>
   149.             log("external trace mode");
   150.       end case;
   151.       if the_histogram_is_enabled                          or else
   152.             the_interrupt_trace_is_enabled                 or else
   153.                the_peripheral_trace_is_enabled             or else
   154.                   the_retrospective_trace_is_enabled       or else
   155.                      the_signature_is_enabled              or else
   156.                         the_external_trace_is_enabled      or else
   157.                            debugging_is_enabled            or else
   158.                               noninteractive_usage_is_enabled then
   159.          log_new_line;
   160.          log(" ... with option(s): ");
   161.          append_option(the_histogram_is_enabled,           "histogram");
   162.          append_option(the_interrupt_trace_is_enabled,     "interrupt trace");
   163.          append_option(the_peripheral_trace_is_enabled,    "peripheral trace");
   164.          append_option(the_retrospective_trace_is_enabled, "retro trace");
   165.          append_option(the_signature_is_enabled,           "signature hash");
   166.          append_option(debugging_is_enabled,               "debugging output");
   167.          append_option(noninteractive_usage_is_enabled,    "noninteractive");
   168.          if needs_comma then
   169.             log_line(".");
   170.          else
   171.             log_line("all disabled.");
   172.             raise emulation_failure with "option processing failure";
   173.          end if;
   174.       else
   175.          log_line(".");
   176.       end if;
   177.       log_rule;
   178.    end display_execution_modes;
   179.
   180.    procedure quit_if_requested is
   181.    begin
   182.       if quit_was_requested then
   183.          raise quit_request;
   184.       end if;
   185.    end quit_if_requested;
   186.
   187.    procedure change_diagnostic_mode_if_requested is
   188.    begin
   189.       if the_diagnostic_mode_changed then
   190.          the_diagnostic_mode_changed := False;
   191.          raise mode_change_request;
   192.       end if;
   193.    end change_diagnostic_mode_if_requested;
   194.
   195.    procedure set_diagnostic_mode (a_diagnostic_mode : in settings.diagnostic_mode) is
   196.       the_signature_is_appropriate,
   197.       the_histogram_is_appropriate,
   198.       retrospective_tracing_is_appropriate,
   199.       peripheral_tracing_is_appropriate,
   200.       interrupt_tracing_is_appropriate : Boolean;
   201.    begin
   202.       if a_diagnostic_mode = external_mode then
   203.          if (the_diagnostic_mode /= external_mode) and (not the_external_trace_is_enabled) then
   204.             open(the_external_trace_file, the_external_trace_file_name);
   205.          end if;
   206.          the_diagnostic_mode := trace_mode;
   207.          the_external_trace_is_enabled := True;
   208.       else
   209.          the_diagnostic_mode := a_diagnostic_mode;
   210.       end if;
   211.       case a_diagnostic_mode is
   212.          when fast_mode =>
   213.             debugging_is_enabled := False;
   214.             the_signature_is_appropriate := False;
   215.             the_histogram_is_appropriate := False;
   216.             retrospective_tracing_is_appropriate := False;
   217.             peripheral_tracing_is_appropriate := False;
   218.             interrupt_tracing_is_appropriate := False;
   219.          when trace_mode | external_mode | pause_mode =>
   220.             the_signature_is_appropriate := True;
   221.             the_histogram_is_appropriate := True;
   222.             retrospective_tracing_is_appropriate := True;
   223.             peripheral_tracing_is_appropriate := True;
   224.             interrupt_tracing_is_appropriate := (the_execution_mode = boot_mode);
   225.       end case;
   226.       the_signature_is_enabled :=
   227.          the_signature_is_requested and the_signature_is_appropriate;
   228.       the_histogram_is_enabled :=
   229.          the_histogram_is_requested and the_histogram_is_appropriate;
   230.       the_retrospective_trace_is_enabled :=
   231.          retrospective_tracing_is_requested and retrospective_tracing_is_appropriate;
   232.       the_peripheral_trace_is_enabled :=
   233.          peripheral_tracing_is_requested and peripheral_tracing_is_appropriate;
   234.       the_interrupt_trace_is_enabled :=
   235.          interrupt_tracing_is_requested and interrupt_tracing_is_appropriate;
   236.    end set_diagnostic_mode;
   237.
   238.    procedure set_execution_mode (an_execution_mode : in settings.execution_mode) is
   239.    begin
   240.       the_execution_mode := an_execution_mode;
   241.    end set_execution_mode;
   242.
   243.    package diagnostic_mode_IO    is new Ada.Text_IO.Enumeration_IO(settings.diagnostic_mode);
   244.
   245.    package execution_mode_IO     is new Ada.Text_IO.Enumeration_IO(settings.execution_mode);
   246.
   247.    package authenticity_mode_IO  is new Ada.Text_IO.Enumeration_IO(settings.authenticity_mode);
   248.
   249.    procedure get_settings_from_file (version : in String) is
   250.
   251.       the_settings_file_name : constant String := "settings_" & version & ".txt";
   252.
   253.       settings_file  : File_Type;
   254.       flag           : Character;
   255.       counts_are_set : Boolean := False;
   256.
   257.       procedure set_this_miscellany_flag is
   258.          option : Character;
   259.       begin
   260.          loop
   261.             get(settings_file, option);
   262.             if is_invalid_miscellany_flag(option) then
   263.                raise Data_Error;
   264.             else
   265.                set_this_miscellany_flag(option);
   266.             end if;
   267.          exit when End_Of_Line(settings_file);
   268.          end loop;
   269.       exception
   270.          when error : others =>
   271.             if not End_Of_Line(settings_file) then
   272.                Skip_Line(settings_file);
   273.             end if;
   274.             log_new_line;
   275.             log_line("***** Error in a miscellany specification: '"
   276.                    & option
   277.                    & "' at "
   278.                    & Ada.Exceptions.Exception_Message(error));
   279.       end set_this_miscellany_flag;
   280.
   281.       procedure set_breakpoints is
   282.          start, end_point : KDF9.code_location;
   283.       begin
   284.          begin
   285.             get_address(settings_file, KDF9.word(start));
   286.          exception
   287.             when others =>
   288.                log_new_line;
   289.                log_line("***** Error in lower address; no breakpoint set.");
   290.                return;
   291.          end;
   292.          log_new_line;
   293.          log_line("Lower breakpoint: #" & oct_of(KDF9.code_point'(0, start))
   294.                                  & " (" & dec_of(KDF9.code_point'(0, start)) & ")",
   295.                   iff => the_log_is_wanted);
   296.          is_a_breakpoint(start) := True;
   297.          begin
   298.             get_address(settings_file, KDF9.word(end_point));
   299.          exception
   300.             when Data_Error =>
   301.                log_line("      No upper address: one breakpoint set.", iff => the_log_is_wanted);
   302.                set_breakpoints(start, start);
   303.                return;
   304.          end;
   305.          log_line("Upper breakpoint: #" & oct_of(KDF9.code_point'(5, end_point))
   306.                                  & " (" & dec_of(KDF9.code_point'(5, end_point)) & ")",
   307.                   iff => the_log_is_wanted);
   308.          set_breakpoints(start, end_point);
   309.       exception
   310.          when others =>
   311.             log_line("***** Error setting breakpoints; ignored.");
   312.       end set_breakpoints;
   313.
   314.       procedure set_fetch_points is
   315.          start, end_point : KDF9.address;
   316.       begin
   317.          begin
   318.             get_address(settings_file, KDF9.word(start));
   319.          exception
   320.             when others =>
   321.                log_new_line;
   322.                log_line("***** Error in lower address; no fetchpoint set.");
   323.                return;
   324.          end;
   325.          log_new_line;
   326.          log_line("Lower fetchpoint: #" & oct_of(start) & " (" & dec_of(start) & ")",
   327.                   iff => the_log_is_wanted);
   328.          begin
   329.             get_address(settings_file, KDF9.word(end_point));
   330.          exception
   331.             when Data_Error =>
   332.                log_line("      No upper address: one fetchpoint set.", iff => the_log_is_wanted);
   333.                set_fetch_points(start, start);
   334.                return;
   335.          end;
   336.          log_line("Upper fetchpoint: #" & oct_of(end_point) & " (" & dec_of(end_point) & ")",
   337.                   iff => the_log_is_wanted);
   338.          set_fetch_points(start, end_point);
   339.       exception
   340.          when others =>
   341.             log_line("***** Error setting fetch points; ignored.");
   342.       end set_fetch_points;
   343.
   344.       procedure set_store_points is
   345.          start, end_point : KDF9.address;
   346.       begin
   347.          begin
   348.             get_address(settings_file, KDF9.word(start));
   349.          exception
   350.             when others =>
   351.                log_new_line;
   352.                log_line("***** Error in lower address; no storepoint set.");
   353.                return;
   354.          end;
   355.          log_new_line;
   356.          log_line("Lower storepoint: #" & oct_of(start) & " (" & dec_of(start) & ")",
   357.                   iff => the_log_is_wanted);
   358.          begin
   359.             get_address(settings_file, KDF9.word(end_point));
   360.          exception
   361.             when Data_Error =>
   362.                log_line("      No upper address: one storepoint set.", iff => the_log_is_wanted);
   363.                set_store_points(start, start);
   364.                return;
   365.          end;
   366.          log_line("Upper storepoint: #" & oct_of(end_point) & " (" & dec_of(end_point) & ")",
   367.                   iff => the_log_is_wanted);
   368.          set_store_points(start, end_point);
   369.       exception
   370.          when others =>
   371.             log_line("***** Error setting store_points; ignored.");
   372.       end set_store_points;
   373.
   374.       procedure set_watchpoints is
   375.          start, end_point : KDF9.address;
   376.       begin
   377.          begin
   378.             get_address(settings_file, KDF9.word(start));
   379.          exception
   380.             when others =>
   381.                log_new_line;
   382.                log_line("***** Error in lower address; no watchpoint set.");
   383.                return;
   384.          end;
   385.          log_new_line;
   386.          log_line("Lower watchpoint: #" & oct_of(start) & " (" & dec_of(start) & ")",
   387.                   iff => the_log_is_wanted);
   388.          begin
   389.             get_address(settings_file, KDF9.word(end_point));
   390.          exception
   391.             when Data_Error =>
   392.                log_line("      No upper address: one watchpoint set.", iff => the_log_is_wanted);
   393.                set_store_points(start, start);
   394.                return;
   395.          end;
   396.          log_line("Upper watchpoint: #" & oct_of(end_point) & " (" & dec_of(end_point) & ")",
   397.                   iff => the_log_is_wanted);
   398.          set_fetch_points(start, end_point);
   399.          set_store_points(start, end_point);
   400.       exception
   401.          when others =>
   402.             log_line("***** Error setting watch points; ignored.");
   403.       end set_watchpoints;
   404.
   405.       procedure set_specified_dumping_ranges (epoch : in dumping.flag) is
   406.          use dumping.flag_support;
   407.          format : dumping.format_set := no_dumping_flag or epoch;
   408.          first_address, last_address : KDF9.address := 0;
   409.          bad_range : Boolean := False;
   410.          data : KDF9.word;
   411.          c  : Character;
   412.          OK : Boolean;
   413.       begin
   414.          while not End_Of_Line(settings_file) loop
   415.             get(settings_file, c);
   416.          exit when c = ' ';
   417.             format := format or dumping_flag(c);
   418.          end loop;
   419.          log_new_line;
   420.          log_line("Dump: format " & format_image(format), iff => the_log_is_wanted);
   421.          if (format and is_parameter_flag) /= no_dumping_flag then
   422.             get_address(settings_file, data);
   423.             if data > max_address then
   424.                log_line("***** Error: Lower dump address  = #" & oct_of(data) & " > 32K-1");
   425.                bad_range := True;
   426.             else
   427.                first_address := KDF9.address(data);
   428.                log_line("      Lower dump address: #" & oct_of(first_address)
   429.                                                & " (" & dec_of(first_address) & ")",
   430.                         iff => the_log_is_wanted);
   431.             end if;
   432.             get_address(settings_file, data);
   433.             if data > max_address then
   434.                log_line("***** Error: Upper dump address: #" & oct_of(data) & " > 32K-1");
   435.                bad_range := True;
   436.             else
   437.                last_address := KDF9.address(data);
   438.                log_line("      Upper dump address: #" & oct_of(last_address)
   439.                                                & " (" & dec_of(last_address) & ")",
   440.                         iff => the_log_is_wanted);
   441.             end if;
   442.          end if;
   443.          if bad_range then
   444.             log_line("***** Error: No dump specification set.");
   445.          else
   446.             request_a_dumping_area(format, first_address, last_address, OK);
   447.          if not OK then
   448.             log_line("***** Error: Too many dump specifications (ignored).");
   449.          end if;
   450.          end if;
   451.          if not End_Of_Line(settings_file) then Skip_Line(settings_file); end if;
   452.       exception
   453.          when others =>
   454.             if not End_Of_Line(settings_file) then Skip_Line(settings_file); end if;
   455.             log_new_line;
   456.             log_line("***** Error in a dump area specification: "
   457.                       & "format "
   458.                       & format_image(format)
   459.                       & "; Lower dump address = #" & oct_of(first_address)
   460.                       & " (" & dec_of(first_address) & ")"
   461.                       & "; Upper dump address = #" & oct_of(last_address)
   462.                       & " (" & dec_of(last_address) & ")");
   463.       end set_specified_dumping_ranges;
   464.
   465.       procedure set_initial_dumping_ranges is
   466.       begin
   467.          set_specified_dumping_ranges(initial_dump_flag);
   468.       end set_initial_dumping_ranges;
   469.
   470.       procedure set_final_dumping_ranges is
   471.       begin
   472.          set_specified_dumping_ranges(final_dump_flag);
   473.       end set_final_dumping_ranges;
   474.
   475.       procedure set_time_limit is
   476.       begin
   477.          get_decimal(settings_file, KDF9.word(time_limit));
   478.          if not counts_are_set then
   479.             high_count := time_limit;
   480.          end if;
   481.          log_new_line;
   482.          log_line("Time limit (in instructions) =" & KDF9.order_counter'Image(time_limit),
   483.                   iff => the_log_is_wanted);
   484.       exception
   485.          when others =>
   486.             if not End_Of_Line(settings_file) then Skip_Line(settings_file); end if;
   487.             time_limit := time_limit_default;
   488.             log_new_line;
   489.             log_line("***** Error in a time limit; default used.");
   490.             log_line("Time limit (in instructions) =" & KDF9.order_counter'Image(time_limit));
   491.       end set_time_limit;
   492.
   493.       procedure set_tracing_counts is
   494.
   495.          procedure show_counts is
   496.          begin
   497.             if not the_log_is_wanted then return; end if;
   498.             log_new_line;
   499.             log_line("Lower tracing count:" & KDF9.order_counter'Image(low_count));
   500.             log_line("Upper tracing count:" & KDF9.order_counter'Image(high_count));
   501.          end show_counts;
   502.
   503.       begin
   504.          get_decimal(settings_file, KDF9.word(low_count));
   505.          get_decimal(settings_file, KDF9.word(high_count));
   506.          show_counts;
   507.          if low_count > high_count then
   508.             log_new_line;
   509.             log_line("***** Error: Low count > high count");
   510.             raise Data_Error;
   511.          end if;
   512.          counts_are_set := True;
   513.       exception
   514.          when others =>
   515.             if not End_Of_Line(settings_file) then Skip_Line(settings_file); end if;
   516.             low_count  := low_count_default;
   517.             high_count := high_count_default;
   518.             log_new_line;
   519.             log_line("***** Error in a tracing count; defaults used.");
   520.             show_counts;
   521.       end set_tracing_counts;
   522.
   523.       procedure set_tracing_range is
   524.
   525.          procedure show_range is
   526.          begin
   527.             if not the_log_is_wanted then return; end if;
   528.             log_new_line;
   529.             log_line("Lower trace address: #" & oct_of(KDF9.code_point'(0, low_bound))
   530.                                        & " (" & dec_of(KDF9.code_point'(0, low_bound)) & ")");
   531.             log_line("Upper trace address: #" & oct_of(KDF9.code_point'(5, high_bound))
   532.                                        & " (" & dec_of(KDF9.code_point'(5, high_bound)) & ")");
   533.          end show_range;
   534.
   535.       begin
   536.          get_address(settings_file, KDF9.word(low_bound));
   537.          get_address(settings_file, KDF9.word(high_bound));
   538.          if low_bound > high_bound then
   539.             log_new_line;
   540.             log_line("***** Error: Low bound > high bound");
   541.             raise Data_Error;
   542.          end if;
   543.          show_range;
   544.       exception
   545.          when others =>
   546.             if not End_Of_Line(settings_file) then Skip_Line(settings_file); end if;
   547.             low_bound  := low_bound_default;
   548.             high_bound := high_bound_default;
   549.             log_new_line;
   550.             log_line("***** Error in a tracing address; defaults used.");
   551.             show_range;
   552.       end set_tracing_range;
   553.
   554.       procedure set_diagnostic_mode is
   555.          use diagnostic_mode_IO;
   556.          the_diagnostic_mode : settings.diagnostic_mode;
   557.       begin
   558.          ensure_not_at_end_of_line(settings_file);
   559.          get(settings_file, the_diagnostic_mode);
   560.          set_diagnostic_mode(the_diagnostic_mode);
   561.       exception
   562.          when others =>
   563.             if not End_Of_Line(settings_file) then Skip_Line(settings_file); end if;
   564.             set_diagnostic_mode(the_diagnostics_default);
   565.             log_new_line;
   566.             log_line("***** Error in the diagnostic mode; default used.");
   567.       end set_diagnostic_mode;
   568.
   569.       procedure set_execution_mode is
   570.          use execution_mode_IO;
   571.       begin
   572.          ensure_not_at_end_of_line(settings_file);
   573.          get(settings_file, the_execution_mode);
   574.       exception
   575.          when others =>
   576.             if not End_Of_Line(settings_file) then Skip_Line(settings_file); end if;
   577.             the_execution_mode := the_execution_default;
   578.             log_new_line;
   579.             log_line("***** Error in the testing mode; default used.");
   580.       end set_execution_mode;
   581.
   582.       procedure set_authenticity is
   583.          use authenticity_mode_IO;
   584.       begin
   585.          ensure_not_at_end_of_line(settings_file);
   586.          get(settings_file, the_authenticity_mode);
   587.          if the_authenticity_mode = authentic_time_mode then
   588.             authentic_timing_is_wanted := True;
   589.          end if;
   590.       exception
   591.          when others =>
   592.             if not End_Of_Line(settings_file) then Skip_Line(settings_file); end if;
   593.             the_authenticity_mode := the_authenticity_default;
   594.             log_new_line;
   595.             log_line("***** Error in the authenticity mode; default used.");
   596.       end set_authenticity;
   597.
   598.       procedure set_graph_plotting_pen is
   599.          use postscript;
   600.          use colour_IO;
   601.          use  width_IO;
   602.          the_colour  : pen_colour := the_default_colour;
   603.          the_pen_tip : pen_tip_size  := the_default_pen_tip;
   604.
   605.          procedure show_pen_options is
   606.          begin
   607.             if not the_log_is_wanted then return; end if;
   608.             log_new_line;
   609.             if the_colour /= the_default_colour then
   610.                log_line("The graph plotter pen colour is " & pen_colour'Image(the_colour) & ".");
   611.             end if;
   612.             if the_pen_tip /= the_default_pen_tip then
   613.                log_line("The graph plotter pen tip is " & pen_tip_size'Image(the_pen_tip) & ".");
   614.             end if;
   615.          end show_pen_options;
   616.
   617.          procedure configure_the_plotter is
   618.          begin
   619.             if the_colour /= the_default_colour or the_pen_tip /= the_default_pen_tip then
   620.                set_the_pen_properties(the_colour, the_pen_tip);
   621.                show_pen_options;
   622.             end if;
   623.             the_graph_plotter_is_configured := True;
   624.          end configure_the_plotter;
   625.
   626.       begin  -- set_graph_plotting_pen
   627.          ensure_not_at_end_of_line(settings_file);
   628.          begin
   629.             Get(settings_file, the_colour);
   630.          exception
   631.             when others =>
   632.                log_new_line;
   633.                log_line("***** Error in the plotter pen the_colour; default used.");
   634.          end;
   635.          ensure_not_at_end_of_line(settings_file);
   636.          begin
   637.             Get(settings_file, the_pen_tip);
   638.          exception
   639.             when others =>
   640.                log_new_line;
   641.                log_line("***** Error in the plotter pen tip; default used.");
   642.          end;
   643.          configure_the_plotter;
   644.       exception
   645.          when Data_Error =>
   646.             if not End_Of_Line(settings_file) then Skip_Line(settings_file); end if;
   647.             configure_the_plotter;
   648.       end set_graph_plotting_pen;
   649.
   650.       procedure set_non_interactivity is
   651.       begin
   652.          noninteractive_usage_is_enabled := True;
   653.          time_limit := offline_time_limit;
   654.          begin
   655.             ensure_not_at_end_of_line(settings_file);
   656.             get_decimal(settings_file, KDF9.word(time_limit));
   657.          exception
   658.             when others =>
   659.                if not End_Of_Line(settings_file) then Skip_Line(settings_file); end if;
   660.                log_new_line;
   661.                log_line("***** Error in a time limit; default used.");
   662.          end;
   663.          log_new_line;
   664.          log_line("Non-interactive mode; time limit (in instructions) ="
   665.                 & KDF9.order_counter'Image(time_limit),
   666.                   iff => the_log_is_wanted);
   667.       end set_non_interactivity;
   668.
   669.    begin
   670.       high_count := time_limit;
   671.       open_options_file(settings_file, the_settings_file_name);
   672.       if end_of_file(settings_file) then
   673.          raise End_Error;
   674.       end if;
   675.
   676.       loop
   677.          skip_to_next_nonempty_line(settings_file);
   678.          get(settings_file, flag);
   679.          the_final_state_is_wanted := True;
   680.          case flag is
   681.             when 'A' | 'a' =>
   682.                set_authenticity;
   683.             when 'B' | 'b' =>
   684.                set_breakpoints;
   685.             when 'C' | 'c' =>
   686.                set_tracing_counts;
   687.             when 'D' | 'd' =>
   688.                set_diagnostic_mode;
   689.             when 'F' | 'f' =>
   690.                set_fetch_points;
   691.             when 'G' | 'g' =>
   692.                set_graph_plotting_pen;
   693.             when 'I' | 'i' =>
   694.                set_initial_dumping_ranges;
   695.             when 'L' | 'l' =>
   696.                set_time_limit;
   697.             when 'N' | 'n' =>
   698.                set_non_interactivity;
   699.             when 'P' | 'p' =>
   700.                set_final_dumping_ranges;
   701.             when 'Q' | 'q' =>
   702.                raise quit_request;
   703.             when 'R' | 'r' =>
   704.                set_tracing_range;
   705.             when 'S' | 's' =>
   706.                set_store_points;
   707.             when 'T' | 't' =>
   708.                set_execution_mode;
   709.             when 'V' | 'v' =>
   710.                set_this_miscellany_flag;
   711.             when 'W' | 'w' =>
   712.                set_watchpoints;
   713.             when 'X' | 'x' =>
   714.                only_signature_tracing := True;
   715.             when others =>
   716.                log_new_line;
   717.                log_line("Invalid flag: """
   718.                       & flag
   719.                       & """ at line/column "
   720.                       & Integer'Image(line_number) & "/"
   721.                       & Ada.Text_IO.Count'Image(Col(settings_file))
   722.                       & " of the settings file!");
   723.                log_line(" ...  the valid flags are A,B,C,D,F,G,I,L,N,P,Q,R,S,T,V,W,X, and |");
   724.                skip_line(settings_file);
   725.          end case;
   726.       end loop;
   727.
   728.    exception
   729.
   730.       when End_Error =>
   731.          close_options_file(settings_file, the_settings_file_name);
   732.
   733.       when Data_Error =>
   734.          close_options_file(settings_file, the_settings_file_name);
   735.          log_new_line;
   736.          log_line("***** Error: invalid data in the settings file.");
   737.          log_line("Reading of settings abandoned at line "
   738.                 & Integer'Image(line_number)
   739.                 & " of '" & the_settings_file_name & "'.");
   740.
   741.       when Status_Error =>
   742.          log_new_line;
   743.          log_line("***** Error: could not read from "
   744.                 & the_settings_file_name
   745.                 & " - default settings in force.");
   746.
   747.       when quit_request =>
   748.          close_options_file(settings_file, the_settings_file_name);
   749.          log_new_line;
   750.          log_line("Quit requested at line "
   751.                 & Integer'Image(line_number)
   752.                 & " of '" & the_settings_file_name & "'.");
   753.          log_rule;
   754.          raise;
   755.
   756.       when error : others =>
   757.          close_options_file(settings_file, the_settings_file_name);
   758.          log_new_line;
   759.          log_line("Failure in ee9: "
   760.                 & Ada.Exceptions.Exception_Information(error)
   761.                 & " was raised in 'get_settings_from_file'!");
   762.          log_line("Reading of settings abandoned at line "
   763.                 & Integer'Image(line_number)
   764.                 & " of '" & the_settings_file_name & "'!");
   765.          log_rule;
   766.          raise emulation_failure;
   767.
   768.    end get_settings_from_file;
   769.
   770. end settings;

Compiling: ../Source\settings.ads
Source file time stamp: 2015-06-18 00:55:40
Compiled at: 2015-10-28 18:13:29

     1. -- settings.ads
     2. --
     3. -- execution mode, diagnostic mode, and other emulation-control settings
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9;
    20. with logging.file;
    21.
    22. use  KDF9;
    23. use  logging.file;
    24.
    25. package settings is
    26.
    27.    pragma Unsuppress(All_Checks);
    28.
    29. --
    30.    -- In fast mode: code runs as efficiently as possible, without diagnostics.
    31.
    32.    -- In trace mode: breakpoints, watchpoints, tracing address bounds and
    33.    --    tracing instruction count bounds are all honoured;
    34.    --       entries may be made in all the retrospective trace logs;
    35.    --          a digital execution signature may be computed,
    36.    --             and an instruction-frequency histogram may be generated.
    37.
    38.    -- In pause mode: execution proceeds as in trace mode;
    39.    --    additionally, breakpoints occur on every order executed within trace bounds.
    40.
    41.    -- The external mode is a user-interface value only. It requests the trace mode,
    42.    --    combined with the logging of a running trace to an external file.
    43. --
    44.
    45.    type diagnostic_mode is (fast_mode,
    46.                             trace_mode,
    47.                             pause_mode,
    48.                             external_mode);
    49.
    50.    procedure set_diagnostic_mode (a_diagnostic_mode : in settings.diagnostic_mode);
    51.
    52.    procedure change_diagnostic_mode_if_requested;
    53.
    54.    the_diagnostics_default  : constant settings.diagnostic_mode := fast_mode;
    55.    the_diagnostic_mode      : settings.diagnostic_mode := the_diagnostics_default;
    56.
    57.    the_external_trace_file_name : constant String := "trace.txt";
    58.    only_signature_tracing       : Boolean := False;
    59.    the_external_trace_file      : logging.file.output;
    60.
    61.    -- The diagnostic generation and display controls, inter alia.
    62.    -- The *_trace_is_wanted flags are set to True iff
    63.    --    they are both requested, and offered by the_diagnostic_mode.
    64.    -- These requests may be set by the miscellany and visibilty options.
    65.
    66.    miscellany_flags  : constant String := "adefghilnprstz0123456789";
    67.    miscellany_prompt : constant String := "{a|d|e|f|g|h|i|l|n|p|r|s|t|z|1..9}";
    68.
    69.    the_log_is_wanted,
    70.    API_logging_is_requested,
    71.    the_signature_is_requested,
    72.    the_histogram_is_requested,
    73.    peripheral_tracing_is_requested,
    74.    interrupt_tracing_is_requested,
    75.    retrospective_tracing_is_requested,
    76.    the_final_state_is_wanted  : Boolean := True;
    77.
    78.    the_graph_plotter_is_configured,
    79.    noninteractive_usage_is_enabled,
    80.    debugging_is_enabled,
    81.    the_signature_is_enabled,
    82.    the_histogram_is_enabled,
    83.    the_peripheral_trace_is_enabled,
    84.    the_interrupt_trace_is_enabled,
    85.    the_retrospective_trace_is_enabled,
    86.    the_external_trace_is_enabled  : Boolean := False;
    87.
    88.    -- This option may also be set by an authenticity option.
    89.    authentic_timing_is_wanted : Boolean := False;
    90.
    91.    -- In boot_mode: a Director program is read from TR0 and executed
    92.    --    in Director state, with full use of the emulated hardware.
    93.    -- In program_mode: a user program is read from TR0 and executed
    94.    --    in program state, with basic OUTs implemented by the emulator.
    95.    -- In test_program_mode: a user program is read from TR0 and executed
    96.    --    in Director state, with basic OUTs implemented by the emulator,
    97.    --    this being useful for executing "hardware test" programs.
    98.
    99.    type execution_mode is (boot_mode, program_mode, test_program_mode);
   100.
   101.    procedure set_execution_mode (an_execution_mode : in settings.execution_mode);
   102.
   103.    the_execution_default : constant settings.execution_mode := program_mode;
   104.    the_execution_mode    :          settings.execution_mode := the_execution_default;
   105.
   106.
   107.    -- In lax_mode, NOUV is NOT caused by an order that increases the nest depth,
   108.    --    or leaves it the same, even if the nest contains too few cells for the operation:
   109.    --       e.g., obeying REV or DUP with a nest depth of less than 2.
   110.    -- KDF9 did not detect an error in these cases but ee9 does, in strict_mode, by default.
   111.    -- N.B. In both nest modes, the test is made BEFORE the operation, unlike KDF9.
   112.    --
   113.    -- Moreover, in lax_mode, any attempt to update Q0 is ignored,
   114.    --    but in strict_mode it is treated as an invalid instruction.
   115.
   116.    type authenticity_mode is (lax_mode, strict_mode, authentic_time_mode);
   117.
   118.    the_authenticity_default : constant settings.authenticity_mode := strict_mode;
   119.    the_authenticity_mode    :          settings.authenticity_mode := the_authenticity_default;
   120.
   121.
   122.    -- Tracing bound settings.
   123.
   124.    -- time_limit bounds the number of KDF9 instructions executed.
   125.
   126.    time_limit_default : constant KDF9.order_counter := KDF9.order_counter'Last;
   127.    time_slice         : constant KDF9.order_counter := 10_000;
   128.    offline_time_limit : constant KDF9.order_counter := 10_000 * time_slice;
   129.    time_limit         :          KDF9.order_counter := time_limit_default;
   130.
   131.
   132.    -- low_bound and high_bound bound the static scope of tracing.
   133.
   134.    low_bound_default  : constant KDF9.code_location := 0;
   135.    high_bound_default : constant KDF9.code_location := KDF9.code_location'Last;
   136.    low_bound          :          KDF9.code_location := low_bound_default;
   137.    high_bound         :          KDF9.code_location := high_bound_default;
   138.
   139.    -- low_count and high_count bound the dynamic scope of tracing.
   140.
   141.    low_count_default  : constant KDF9.order_counter := 0;
   142.    high_count_default : constant KDF9.order_counter := time_limit_default;
   143.    low_count          :          KDF9.order_counter := low_count_default;
   144.    high_count         :          KDF9.order_counter := high_count_default;
   145.
   146.
   147.    function is_invalid_miscellany_flag (option : in Character)
   148.    return Boolean;
   149.
   150.    procedure set_this_miscellany_flag (option : in Character);
   151.
   152.    procedure get_settings_from_file (version : in String);
   153.
   154.    procedure display_execution_modes;
   155.
   156.    procedure quit_if_requested;
   157.
   158.    quit_was_requested          : Boolean := False;
   159.
   160.    the_diagnostic_mode_changed : Boolean := False;
   161.
   162.    mode_change_request         : exception;
   163.
   164. end settings;

 770 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\toggle_the_shared_buffer.adb
Source file time stamp: 2015-06-18 00:55:34
Compiled at: 2015-10-28 18:13:33

     1. -- toggle_the_shared_buffer.adb
     2. --
     3. -- Switch the shared buffer from TP1 to GP0 if necessary.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with HCI;
    20. with IOC.two_shift.GP;
    21. with IOC.two_shift.TP;
    22. with settings;
    23.
    24. use  HCI;
    25. use  IOC.two_shift.GP;
    26. use  IOC.two_shift.TP;
    27. use  settings;
    28.
    29. procedure toggle_the_shared_buffer is
    30. begin
    31.    if the_graph_plotter_is_configured then
    32.       -- Switch the shared buffer from TP1 to GP0;
    33.       switch_the_shared_buffer_from_TP1;
    34.       switch_the_shared_buffer_onto_GP0;
    35.       if the_log_is_wanted then
    36.          log_new_line;
    37.          log_line("The shared buffer has been switched from TP1 to GP0.");
    38.          log_new_line;
    39.       end if;
    40.    end if;
    41. end toggle_the_shared_buffer;

 41 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\configuration.ads
Source file time stamp: 2015-06-18 00:57:02
Compiled at: 2015-10-28 18:13:33

     1. -- configuration.ads
     2. --
     3. -- IOC components needing elaboration: these are the devices included in the KDF9 configuration.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with IOC.two_shift.FW;
    20. with IOC.two_shift.TR;
    21. with IOC.two_shift.TP;
    22. with IOC.two_shift.GP;
    23. with IOC.LP;
    24. with IOC.CR;
    25. with IOC.CP;
    26. with IOC.magtape.MT; pragma Elaborate_All(IOC.magtape.MT);
    27. with IOC.magtape.ST; pragma Elaborate_All(IOC.magtape.ST);
    28. --with IOC.DR;
    29. with IOC.FD;
    30.
    31. pragma Unreferenced(IOC.two_shift.FW);
    32.
    33. pragma Unreferenced(IOC.two_shift.TR);
    34.
    35. pragma Unreferenced(IOC.two_shift.TP);
    36.
    37. pragma Unreferenced(IOC.two_shift.GP);
    38.
    39. pragma Unreferenced(IOC.LP);
    40.
    41. pragma Unreferenced(IOC.CR);
    42.
    43. pragma Unreferenced(IOC.CP);
    44.
    45. pragma Unreferenced(IOC.magtape.MT);
    46.
    47. pragma Unreferenced(IOC.magtape.ST);
    48.
    49. --pragma Unreferenced(IOC.DR);
    50.
    51. pragma Unreferenced(IOC.FD);
    52.
    53. package configuration is
    54.
    55.    pragma Unsuppress(All_Checks);
    56.
    57. end configuration;

 57 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\finalize_ee9.adb
Source file time stamp: 2015-06-18 00:56:50
Compiled at: 2015-10-28 18:13:33

     1. -- finalize_ee9.adb
     2. --
     3. -- Shut down processing in preparation for a dignified exit.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Exceptions;
    20. --
    21. with HCI;
    22. with IOC;
    23. with state_display;
    24.
    25. use  HCI;
    26. use  IOC;
    27. use  state_display;
    28.
    29. procedure finalize_ee9 is
    30.
    31.    pragma Unsuppress(All_Checks);
    32.
    33. begin
    34.    show_final_state;
    35.    finalize_all_KDF9_buffers;
    36. exception
    37.    when error : others =>
    38.       log_line("Failure in ee9: "
    39.              & Ada.Exceptions.Exception_Information(error)
    40.              & " was raised in 'finalize_ee9'!");
    41. end finalize_ee9;

Compiling: ../Source\finalize_ee9.ads
Source file time stamp: 2015-06-18 00:56:50
Compiled at: 2015-10-28 18:13:33

     1. -- finalize_ee9.ads
     2. --
     3. -- Shut down processing in preparation for a dignified exit.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. procedure finalize_ee9;

 41 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc.adb
Source file time stamp: 2015-06-18 00:56:16
Compiled at: 2015-10-28 18:13:34

     1. -- ioc.adb
     2. --
     3. -- Emulation of the common functionality of a KDF9 IOC "buffer" (DMA channel),
     4. --    with fail-stop stubs for operations having device-specific behaviour.
     5. --
     6. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     7. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     8. --
     9. -- The ee9 program is free software; you can redistribute it and/or
    10. -- modify it under terms of the GNU General Public License as published
    11. -- by the Free Software Foundation; either version 3, or (at your option)
    12. -- any later version. This program is distributed in the hope that it
    13. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    14. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    15. -- See the GNU General Public License for more details. You should have
    16. -- received a copy of the GNU General Public License distributed with
    17. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    18. --
    19.
    20. with Ada.Exceptions;
    21. --
    22. with formatting;
    23. with KDF9.CPU;
    24. with KDF9.PHU_store;
    25. with KDF9.store;
    26. with settings;
    27.
    28. use  formatting;
    29. use  KDF9.CPU;
    30. use  KDF9.PHU_store;
    31. use  KDF9.store;
    32. use  settings;
    33.
    34. package body IOC is
    35.
    36.    pragma Unsuppress(All_Checks);
    37.
    38.    procedure set_state_of (the_buffer : in device_class_access;
    39.                            allocated  : in Boolean) is
    40.    begin
    41.       if the_buffer.is_allocated = allocated then
    42.          -- Allocating an already allocated device, or deallocating an unallocated device.
    43.          if the_buffer.is_allocated then
    44.             raise emulation_failure with "attempt to allocate an allocated device";
    45.          else
    46.             raise emulation_failure with "attempt to deallocate an unallocated device";
    47.          end if;
    48.       else
    49.          the_buffer.is_allocated := allocated;
    50.          the_CPDAR(the_buffer.number) := Boolean'Pos(allocated);
    51.       end if;
    52.     end set_state_of;
    53.
    54.    function is_unallocated (the_buffer : device_class_access)
    55.    return Boolean is
    56.    begin
    57.       return not the_buffer.is_allocated;
    58.    end is_unallocated;
    59.
    60.    function logical_device_name_of (the_buffer : IOC.device)
    61.    return KDF9.logical_device_name is
    62.    begin
    63.       return IOC.device_kind'Image(the_buffer.kind)(1 .. 2)
    64.            & trimmed(KDF9.buffer_number'Image(the_buffer.unit));
    65.    end logical_device_name_of;
    66.
    67.    function logical_device_name_of (the_number : IOC.device_number)
    68.    return KDF9.logical_device_name is
    69.    begin
    70.       return logical_device_name_of(buffer(the_number).all);
    71.    end logical_device_name_of;
    72.
    73.    overriding
    74.    procedure Initialize (the_buffer : in out IOC.device) is
    75.    begin
    76.       if not IOC.device'Class(the_buffer).is_open then
    77.          if the_buffer.kind = MT_kind or
    78.                the_buffer.kind = ST_kind or
    79.                   the_buffer.kind = DR_kind then
    80.             null;
    81.          else
    82.             output_line(the_buffer.device_name
    83.                       & " is on buffer #"
    84.                       & oct_of(KDF9.Q_part(the_buffer.number), 2)
    85.                       & ", but the device is offline!");
    86.          end if;
    87.          the_buffer.is_abnormal := True;
    88.          the_buffer.is_offline  := True;
    89.       end if;
    90.       install(the_buffer);
    91.    end Initialize;
    92.
    93.    procedure open (the_buffer : in out IOC.device'Class;
    94.                    the_mode   : in POSIX.access_mode;
    95.                    attaching  : in Boolean := False;
    96.                    to_fd      : in Integer := no_fd) is
    97.    begin
    98.       the_buffer.device_name := logical_device_name_of(the_buffer);
    99.       if attaching then
   100.          open(the_buffer.stream, the_buffer.device_name, the_mode, to_fd);
   101.          null;  -- Do not truncate an already open output stream.
   102.       else
   103.          open(the_buffer.stream, the_buffer.device_name, the_mode);
   104.          if the_mode = write_mode and the_buffer.is_open then
   105.             truncate(the_buffer.stream, to_length => 0);
   106.          end if;
   107.       end if;
   108.       IOC.device(the_buffer).Initialize;
   109.    end open;
   110.
   111.    overriding
   112.    procedure Finalize (the_buffer : in out IOC.device) is
   113.    begin
   114.       if IOC.device'Class(the_buffer).is_open   and then
   115.             IOC.device'Class(the_buffer).usage /= 0 then
   116.          IOC.device'Class(the_buffer).close;
   117.       end if;
   118.    exception
   119.       when error : others =>
   120.          output_line("Finalize for buffer #"
   121.                    & oct_of(KDF9.Q_part(the_buffer.number))
   122.                    & "; "
   123.                    & Ada.Exceptions.Exception_Information(error));
   124.    end Finalize;
   125.
   126.    function is_open (the_buffer : IOC.device)
   127.    return Boolean is
   128.    begin
   129.       return the_buffer.stream.is_open;
   130.    end is_open;
   131.
   132.    function usage (the_buffer : IOC.device)
   133.    return KDF9.word is
   134.    begin
   135.       return the_buffer.stream.bytes_moved;
   136.    end usage;
   137.
   138.    procedure flush (the_buffer : in out IOC.device) is
   139.    begin
   140.       flush(the_buffer.stream);
   141.    end flush;
   142.
   143.    procedure close (the_buffer : in out IOC.device) is
   144.    begin
   145.       close(the_buffer.stream);
   146.       IOC.buffer(the_buffer.number) := null;
   147.    end close;
   148.
   149.    procedure finalize_all_KDF9_buffers is
   150.    begin
   151.       for b in IOC.buffer'Range loop
   152.          if IOC.buffer(b) /= null then
   153.             Finalize(IOC.buffer(b).all);
   154.          else
   155.             output_line("There is no device on buffer #" & oct_of(b) & "!");
   156.          end if;
   157.       end loop;
   158.    end finalize_all_KDF9_buffers;
   159.
   160.    procedure add_in_the_IO_lockout_CPU_time (Q_operand : in KDF9.Q_register) is
   161.       IO_size : constant KDF9.Q_part := Q_operand.M - Q_operand.I;
   162.    begin
   163.       the_CPU_delta := the_CPU_delta + KDF9.microseconds(IO_size + group_size) / group_size;
   164.    end add_in_the_IO_lockout_CPU_time;
   165.
   166.    function IO_elapsed_time (the_buffer   : IOC.device;
   167.                              atomic_items : KDF9.word)
   168.    return KDF9.microseconds is
   169.    begin
   170.       if IOC.device'Class(the_buffer).is_open then
   171.          return KDF9.microseconds(atomic_items) * the_buffer.quantum;
   172.       else
   173.          return 0;
   174.       end if;
   175.    end IO_elapsed_time;
   176.
   177.    procedure add_in_the_IO_CPU_time (IO_CPU_time : in KDF9.microseconds) is
   178.    begin
   179.       the_CPU_delta := the_CPU_delta + IO_CPU_time;
   180.    end add_in_the_IO_CPU_time;
   181.
   182.    procedure add_in_the_IO_CPU_time (the_buffer  : in IOC.device'Class;
   183.                                      bytes_moved : in KDF9.word) is
   184.       the_IO_CPU_time : KDF9.microseconds;
   185.    begin
   186.       if the_buffer.is_open then
   187.          if the_buffer.is_slow then
   188.             the_IO_CPU_time := KDF9.microseconds(bytes_moved)*6;     -- 6µs/char
   189.          else
   190.             the_IO_CPU_time := KDF9.microseconds(bytes_moved)*6 / 8; -- 6µs/word
   191.          end if;
   192.       else
   193.          the_IO_CPU_time := 0;
   194.       end if;
   195.       add_in_the_IO_CPU_time(the_IO_CPU_time);
   196.    end add_in_the_IO_CPU_time;
   197.
   198.    function IO_elapsed_time_total (the_buffer : IOC.device)
   199.    return KDF9.microseconds is
   200.    begin
   201.       return IO_elapsed_time(IOC.device'Class(the_buffer), IOC.device'Class(the_buffer).usage);
   202.    end IO_elapsed_time_total;
   203.
   204.    procedure install (the_device : in out IOC.device'Class) is
   205.    begin
   206.       if the_device.number = ND0_number then
   207.          -- This device is not to be included in the configuration.
   208.          return;
   209.       end if;
   210.       if buffer(the_device.number) /= null then
   211.          raise emulation_failure with
   212.             "Attempt to install a second device, namely "
   213.           & logical_device_name_of(the_device)
   214.           & ", on buffer #"
   215.           & oct_of(the_device.number);
   216.       end if;
   217.       buffer(the_device.number) := the_device'Unchecked_Access;
   218.    end install;
   219.
   220.    function canonical (Q_operand : KDF9.Q_register)
   221.    return KDF9.Q_register is
   222.    begin
   223.       return (
   224.               C => Q_operand.C and buffer_number_mask,
   225.               I => Q_operand.I,
   226.               M => Q_operand.M
   227.              );
   228.    end canonical;
   229.
   230.    procedure validate_device (the_buffer : in IOC.device'Class;
   231.                               Q_operand  : in KDF9.Q_register) is
   232.       Q : constant KDF9.Q_register := canonical(Q_operand);
   233.    begin
   234.       if not the_buffer.is_open then
   235.          trap_invalid_instruction(the_buffer.device_name
   236.                                 & " on buffer #"
   237.                                 & oct_of(KDF9.Q_part(the_buffer.number), 2)
   238.                                 & " is offline");
   239.       end if;
   240.       if KDF9.Q_part(the_buffer.number) /= Q.C then
   241.          raise emulation_failure
   242.             with "wrong operand: "
   243.                & oct_of(Q.C)
   244.                & " for "
   245.                & the_buffer.device_name
   246.                & " on buffer #"
   247.                & oct_of(KDF9.Q_part(the_buffer.number), 2);
   248.       end if;
   249.       if the_CPDAR(the_buffer.number) = 0 and the_CPU_state /= Director_state then
   250.          trap_invalid_instruction("attempt to use unallocated I/O device #"
   251.                                 & oct_of(the_buffer.number));
   252.       end if;
   253.    end validate_device;
   254.
   255.    procedure validate_bounds (Q_operand  : in KDF9.Q_register) is
   256.    begin
   257.       if Q_operand.I > Q_operand.M then
   258.          trap_invalid_instruction("invalid I/O Q operand: I > M");
   259.       end if;
   260.    end validate_bounds;
   261.
   262.    procedure validate_transfer (the_buffer : in IOC.device'Class;
   263.                                 Q_operand  : in KDF9.Q_register) is
   264.    begin
   265.       validate_device(the_buffer, Q_operand);
   266.       validate_bounds(Q_operand);
   267.    end validate_transfer;
   268.
   269.    procedure validate_parity (the_buffer : in IOC.device'Class) is
   270.    begin
   271.       if the_buffer.is_abnormal then
   272.          trap_invalid_instruction("reading past end of data, or a parity error, on "
   273.                                 & the_buffer.device_name);
   274.       end if;
   275.    end validate_parity;
   276.
   277.    procedure require_nonnegative_count (count : in KDF9.Q_part) is
   278.    begin
   279.       if resign(count) < 0 then
   280.          trap_invalid_instruction("negative I/O repetition count");
   281.       end if;
   282.    end require_nonnegative_count;
   283.
   284.    procedure require_positive_count (count : in KDF9.Q_part) is
   285.    begin
   286.       if resign(count) <= 0 then
   287.          trap_invalid_instruction("nonpositive I/O repetition count");
   288.       end if;
   289.    end require_positive_count;
   290.
   291.    procedure start_timed_transfer (the_buffer   : in out IOC.device'Class;
   292.                                    Q_operand    : in KDF9.Q_register;
   293.                                    set_offline  : in Boolean;
   294.                                    busy_time    : in KDF9.microseconds;
   295.                                    is_DMAing    : in Boolean := True) is
   296.       pragma Unreferenced(set_offline);
   297.    begin
   298.       -- Check the IO parameters and the buffer state, and handle any old lockout.
   299.       validate_device(the_buffer, Q_operand);
   300.       if start_timed_transfer.is_DMAing then
   301.          validate_bounds(Q_operand);
   302.       else
   303.          require_nonnegative_count(Q_operand.M);
   304.       end if;
   305.       validate_parity(the_buffer);
   306.       if the_buffer.is_busy then
   307.          handle_a_buffer_lockout(the_buffer);
   308.       end if;
   309.       if start_timed_transfer.is_DMAing          and then
   310.             KDF9.store.test_lockouts(Q_operand) /= 0 then
   311.          LOV_if_user_mode;
   312.       end if;
   313.       -- Set up the transfer parameters.
   314.       the_buffer.is_for_Director := (the_CPU_state = Director_state);
   315.       the_buffer.priority_level  := CPL;
   316.       the_buffer.control_word    := Q_operand;
   317.       the_buffer.is_DMAing       := is_DMAing;
   318.       the_buffer.order_count     := ICR+1;
   319.       the_buffer.order_address   := CIA;
   320.       the_buffer.decoded_order   := INS;
   321.       the_buffer.initiation_time := the_clock_time;
   322.       the_buffer.transfer_time   := busy_time;
   323.       the_buffer.completion_time := the_buffer.initiation_time + busy_time;
   324.       if busy_time > 0 or is_DMAing then
   325.          if the_buffer.completion_time < the_next_interrupt_time then
   326.             the_next_interrupt_time := the_buffer.completion_time;
   327.          end if;
   328.          the_buffer.is_busy := True;
   329.          take_note_of (start_transfer,
   330.                        the_buffer.order_count,
   331.                        the_buffer.order_address,
   332.                        the_buffer.decoded_order,
   333.                        the_buffer.initiation_time,
   334.                        the_buffer.device_name,
   335.                        the_buffer.completion_time,
   336.                        the_buffer.is_for_Director,
   337.                        the_buffer.priority_level,
   338.                        the_buffer.control_word
   339.                       );
   340.       else -- Take note of, e.g., a disc seek, which does not busy the buffer.
   341.          the_buffer.is_busy := False;
   342.          take_note_of (finis_transfer,
   343.                        the_buffer.order_count,
   344.                        the_buffer.order_address,
   345.                        the_buffer.decoded_order,
   346.                        the_buffer.initiation_time,
   347.                        the_buffer.device_name,
   348.                        the_buffer.completion_time,
   349.                        the_buffer.is_for_Director,
   350.                        the_buffer.priority_level,
   351.                        the_buffer.control_word
   352.                       );
   353.       end if;
   354.       PHU(the_buffer.priority_level) := idle_PHU;
   355.    end start_timed_transfer;
   356.
   357.    -- initialize_byte_mode_transfer takes a pessimistic view of transfers-to-End_Message.
   358.
   359.    -- When the actual transfer length is known, the end-of-transfer time can be
   360.    --    made more realistic by specifying its real length to correct_transfer_time.
   361.
   362.    -- correct_transfer_time must be called before finalize_transfer is called.
   363.
   364.    procedure correct_transfer_time (the_buffer  : in out IOC.device'Class;
   365.                                     actual_time : in KDF9.microseconds) is
   366.    begin
   367.       the_buffer.transfer_time :=  actual_time;
   368.       the_buffer.completion_time := the_buffer.initiation_time + the_buffer.transfer_time;
   369.       if the_buffer.completion_time < the_next_interrupt_time then
   370.          the_next_interrupt_time := the_buffer.completion_time;
   371.       end if;
   372.    end correct_transfer_time;
   373.
   374.    procedure correct_transfer_time (the_buffer    : in out IOC.device'Class;
   375.                                     actual_length : in KDF9.word) is
   376.    begin
   377.       the_buffer.transfer_time := IO_elapsed_time(the_buffer, actual_length);
   378.       the_buffer.completion_time := the_buffer.initiation_time + the_buffer.transfer_time;
   379.       if the_buffer.completion_time < the_next_interrupt_time then
   380.          the_next_interrupt_time := the_buffer.completion_time;
   381.       end if;
   382.    end correct_transfer_time;
   383.
   384.    procedure finalize_transfer (the_buffer : in out IOC.device'Class;
   385.                                 need_EDT,
   386.                                 need_PR    : out Boolean) is
   387.    begin
   388.       if the_buffer.transfer_time /= 0 then
   389.          take_note_of (finis_transfer,
   390.                        the_buffer.order_count,
   391.                        the_buffer.order_address,
   392.                        the_buffer.decoded_order,
   393.                        the_buffer.initiation_time,
   394.                        the_buffer.device_name,
   395.                        the_buffer.completion_time,
   396.                        the_buffer.is_for_Director,
   397.                        the_buffer.priority_level,
   398.                        the_buffer.control_word
   399.                       );
   400.       end if;
   401.       need_EDT := the_buffer.is_for_Director;
   402.       need_PR  := the_buffer.priority_level < CPL;
   403.       PHU(the_buffer.priority_level) := idle_PHU;
   404.       if the_execution_mode = boot_mode then
   405.          -- Test for possible priority inversion, i.e. other program(s) blocked on this buffer.
   406.          for p in PHU'Range loop
   407.             if PHU(p).is_held_up                               and then
   408.                   PHU(p).blockage.reason = buffer_busy         and then
   409.                      PHU(p).blockage.buffer_nr = the_buffer.number then
   410.                -- The EE paper "KDF9 TIME-SHARING DIRECTOR SUPPORT DOCUMENTATION" of 1-May-1965
   411.                --   says such a PHU is NOT cleared, but EDT is requested INSTEAD of PR,
   412.                --   so Director can take action according to what it finds there.
   413.                need_EDT := True;
   414.                need_PR  := False;
   415.             end if;
   416.          end loop;
   417.       end if;
   418.       if the_buffer.is_DMAing then
   419.          clear_lockouts(the_buffer.control_word);
   420.       end if;
   421.       the_buffer.is_busy         := False;
   422.       the_buffer.is_for_Director := False;
   423.       the_buffer.completion_time := KDF9.microseconds'Last;
   424.    end finalize_transfer;
   425.
   426.    procedure act_on_pending_interrupts is
   427.       EDT_needed, PR_needed : Boolean := False;
   428.    begin
   429.       advance_the_clock_past(the_next_interrupt_time);
   430.       -- Predict another interrupt (at most 1 second in the future in Director).
   431.       the_next_interrupt_time := KDF9.microseconds'Last;
   432.       for b in buffer'Range loop
   433.          if buffer(b) /= null and then
   434.                buffer(b).is_busy  then
   435.             if the_clock_time >= buffer(b).completion_time then
   436.                finalize_transfer(buffer(b).all, EDT_needed, PR_needed);
   437.             elsif the_next_interrupt_time > buffer(b).completion_time then
   438.                the_next_interrupt_time := buffer(b).completion_time;
   439.             end if;
   440.          end if;
   441.       end loop;
   442.       if the_execution_mode = boot_mode and then
   443.             the_next_interrupt_time > the_clock_time + 1_000_000 then
   444.          the_next_interrupt_time := the_clock_time + 1_000_000;
   445.       end if;
   446.       if EDT_needed then
   447.          signal_interrupt(EDT_flag);
   448.       elsif PR_needed then
   449.          signal_interrupt(PR_flag);
   450.       end if;
   451.    end act_on_pending_interrupts;
   452.
   453.    -- Advance the time to a point after all extant transfer have terminated,
   454.    --    finalizing all extant transfer in temporal order in the process.
   455.    procedure complete_all_extant_transfers is
   456.       EDT_needed,
   457.       PR_needed      : Boolean := False;
   458.       last_time      : KDF9.microseconds := 0;
   459.       next_time      : KDF9.microseconds;
   460.    begin
   461.       -- At least one transfer is terminated each time around outer_loop,
   462.       --    if not, outer_loop is exited.
   463.    outer_loop:
   464.       for c in buffer'Range loop
   465.          -- Find the earliest transfer termination time.
   466.          next_time := KDF9.microseconds'Last;
   467.          for b in buffer'Range loop
   468.             if buffer(b) /= null and then
   469.                   buffer(b).is_busy and then
   470.                      buffer(b).completion_time < next_time then
   471.                next_time := buffer(b).completion_time;
   472.             end if;
   473.          end loop;
   474.
   475.          if next_time = KDF9.microseconds'Last then
   476.             -- All the buffers are quiescent.
   477.             exit outer_loop;
   478.          else
   479.             -- At least one transfer remains to be finalized.
   480.             advance_the_clock_past(next_time);
   481.             last_time := KDF9.microseconds'Max(last_time, next_time);
   482.          end if;
   483.
   484.          -- Finalize all transfers with completion time <= next_time.
   485.          for b in buffer'Range loop
   486.             if buffer(b) /= null and then
   487.                   buffer(b).is_busy and then
   488.                      buffer(b).completion_time <= next_time then
   489.                finalize_transfer(buffer(b).all, EDT_needed, PR_needed);
   490.             end if;
   491.          end loop;
   492.
   493.       end loop outer_loop;
   494.    end complete_all_extant_transfers;
   495.
   496.    procedure handle_a_buffer_lockout (the_buffer : in IOC.device'Class) is
   497.       the_start_time : constant KDF9.microseconds := the_clock_time;
   498.    begin
   499.       PHU(CPL) := (is_held_up => True,
   500.                    blockage   => (buffer_busy, the_buffer.number, INTQq_wait => 0));
   501.       take_note_of (buffer_lockout, ICR, CIA, INS,
   502.                     initiation_time => the_start_time,
   503.                     device_name     => the_buffer.device_name
   504.                    );
   505.       if the_execution_mode = boot_mode then
   506.          LOV_if_user_mode;
   507.       else
   508.          advance_the_clock_past(the_buffer.completion_time);
   509.          act_on_pending_interrupts;
   510.       end if;
   511.    end handle_a_buffer_lockout;
   512.
   513.    function the_buffer_responsible_for (address : KDF9.Q_part)
   514.    return KDF9.buffer_number is
   515.       candidate_found  : Boolean := False;
   516.       candidate_time   : KDF9.microseconds := KDF9.microseconds'First;
   517.       candidate_number : KDF9.buffer_number;
   518.    begin
   519.       -- Select the buffer active in the_group;
   520.       --    if there is more than one, choose the buffer with the latest completion time.
   521.       -- The latter case should not arise in practice, but is allowed by the hardware.
   522.       for b in buffer'Range loop
   523.          if buffer(b) /= null                                      and then
   524.                buffer(b).is_busy                                   and then
   525.                   buffer(b).completion_time > candidate_time       and then
   526.                      group(address) in group(buffer(b).control_word.I)
   527.                                     .. group(buffer(b).control_word.M) then
   528.             candidate_number := b;
   529.             candidate_time   := buffer(b).completion_time;
   530.             candidate_found  := True;
   531.          end if;
   532.       end loop;
   533.       if candidate_found then
   534.          return candidate_number;
   535.       else
   536.          raise emulation_failure with "cannot identify any buffer responsible for this lockout";
   537.       end if;
   538.    end the_buffer_responsible_for;
   539.
   540.    procedure handle_a_main_store_lockout (address : in KDF9.Q_part) is
   541.       the_start_time : constant KDF9.microseconds := the_clock_time;
   542.       the_buffer     : constant KDF9.buffer_number := the_buffer_responsible_for(address);
   543.    begin
   544.       PHU(CPL) := (is_held_up => True,
   545.                    blockage   => (locked_out, group_address(group(address))));
   546.       -- Store access LOV interrupts invoke instruction restart outside Director.
   547.       if the_execution_mode = boot_mode then
   548.          LOV_if_user_mode;
   549.       else
   550.          set_NIA_to(CIA);
   551.          take_note_of (store_lockout, ICR, CIA, INS,
   552.                        initiation_time => the_start_time,
   553.                        device_name     => logical_device_name_of(buffer(the_buffer).all)
   554.                       );
   555.          advance_the_clock_past(buffer(the_buffer).completion_time);
   556.          act_on_pending_interrupts;
   557.       end if;
   558.       ICR := ICR + 1;
   559.    end handle_a_main_store_lockout;
   560.
   561.    procedure CTQ (the_buffer  : in out IOC.device'Class;
   562.                   Q_operand   : in KDF9.Q_register;
   563.                   set_offline : in Boolean) is
   564.       EDT_needed, PR_needed : Boolean := False;
   565.    begin
   566.       validate_device(the_buffer, Q_operand);
   567.       take_note_of(Q_operand,
   568.                    the_buffer.device_name,
   569.                    KDF9.word(Boolean'Pos(the_buffer.is_busy))
   570.                   );
   571.       if the_buffer.is_busy then
   572.          the_buffer.completion_time := the_clock_time;
   573.          finalize_transfer(the_buffer, EDT_needed, PR_needed);
   574.       end if;
   575.       the_buffer.is_abnormal := False;
   576.       the_buffer.is_offline  := set_offline;
   577.    end CTQ;
   578.
   579.    procedure INT (the_buffer  : in IOC.device'Class;
   580.                   Q_operand   : in KDF9.Q_register;
   581.                   set_offline : in Boolean) is
   582.       pragma Unreferenced(set_offline);
   583.       the_start_time : constant KDF9.microseconds := the_clock_time;
   584.    begin
   585.       validate_device(the_buffer, Q_operand);
   586.       take_note_of(Q_operand,
   587.                    the_buffer.device_name,
   588.                    KDF9.word(Boolean'Pos(the_buffer.is_busy))
   589.                   );
   590.       if the_buffer.is_busy then
   591.          PHU(CPL) := (is_held_up => True,
   592.                       blockage   => (buffer_busy, the_buffer.number, INTQq_wait => 1));
   593.          take_note_of (buffer_lockout, ICR, CIA, INS,
   594.                        initiation_time => the_start_time,
   595.                        device_name     => the_buffer.device_name
   596.                       );
   597.          if the_execution_mode = boot_mode then
   598.             signal_interrupt(PR_flag);
   599.          else
   600.             advance_the_clock_past(the_buffer.completion_time);
   601.             act_on_pending_interrupts;
   602.          end if;
   603.       end if;
   604.    end INT;
   605.
   606.    procedure BUSY (the_buffer  : in IOC.device'Class;
   607.                    Q_operand   : in KDF9.Q_register;
   608.                    set_offline : in Boolean;
   609.                    result      : out KDF9.word) is
   610.       pragma Unreferenced(set_offline);
   611.    begin
   612.       validate_device(the_buffer, Q_operand);
   613.       result := KDF9.word(Boolean'Pos(the_buffer.is_busy));
   614.       take_note_of(Q_operand, the_buffer.device_name, result);
   615.       if the_buffer.is_busy and then
   616.             (the_execution_mode /= boot_mode or the_CPU_state = Director_state) then
   617.          act_on_pending_interrupts;
   618.       end if;
   619.    end BUSY;
   620.
   621.    procedure PAR (the_buffer  : in out IOC.device'Class;
   622.                   Q_operand   : in KDF9.Q_register;
   623.                   set_offline : in Boolean;
   624.                   result      : out KDF9.word) is
   625.       pragma Unreferenced(set_offline);
   626.    begin
   627.       validate_device(the_buffer, Q_operand);
   628.       if the_buffer.is_busy then
   629.          handle_a_buffer_lockout(the_buffer);
   630.       end if;
   631.       result := KDF9.word(Boolean'Pos(the_buffer.is_abnormal));
   632.       take_note_of(Q_operand, the_buffer.device_name, result);
   633.       the_buffer.is_abnormal := False;
   634.    end PAR;
   635.
   636.    procedure PIA (the_buffer  : in out IOC.device;
   637.                   Q_operand   : in KDF9.Q_register;
   638.                   set_offline : in Boolean) is
   639.       pragma Unreferenced(set_offline);
   640.    begin
   641.       validate_transfer(the_buffer, Q_operand);
   642.       validate_parity(the_buffer);
   643.       trap_invalid_instruction("PIA cannot be used on " & the_buffer.device_name);
   644.    end PIA;
   645.
   646.    procedure PIB (the_buffer  : in out IOC.device;
   647.                   Q_operand   : in KDF9.Q_register;
   648.                   set_offline : in Boolean) is
   649.       pragma Unreferenced(set_offline);
   650.    begin
   651.       validate_transfer(the_buffer, Q_operand);
   652.       validate_parity(the_buffer);
   653.       trap_invalid_instruction("PIB cannot be used on " & the_buffer.device_name);
   654.    end PIB;
   655.
   656.    procedure PIC (the_buffer  : in out IOC.device;
   657.                   Q_operand   : in KDF9.Q_register;
   658.                   set_offline : in Boolean) is
   659.       pragma Unreferenced(set_offline);
   660.    begin
   661.       validate_transfer(the_buffer, Q_operand);
   662.       validate_parity(the_buffer);
   663.       trap_invalid_instruction("PIC cannot be used on " & the_buffer.device_name);
   664.    end PIC;
   665.
   666.    procedure PID (the_buffer  : in out IOC.device;
   667.                   Q_operand   : in KDF9.Q_register;
   668.                   set_offline : in Boolean) is
   669.       pragma Unreferenced(set_offline);
   670.    begin
   671.       validate_transfer(the_buffer, Q_operand);
   672.       validate_parity(the_buffer);
   673.       trap_invalid_instruction("PID cannot be used on " & the_buffer.device_name);
   674.    end PID;
   675.
   676.    procedure PIE (the_buffer  : in out IOC.device;
   677.                   Q_operand   : in KDF9.Q_register;
   678.                   set_offline : in Boolean) is
   679.       pragma Unreferenced(set_offline);
   680.    begin
   681.       validate_transfer(the_buffer, Q_operand);
   682.       validate_parity(the_buffer);
   683.       trap_invalid_instruction("PIE cannot be used on " & the_buffer.device_name);
   684.    end PIE;
   685.
   686.    procedure PIF (the_buffer  : in out IOC.device;
   687.                   Q_operand   : in KDF9.Q_register;
   688.                   set_offline : in Boolean) is
   689.       pragma Unreferenced(set_offline);
   690.    begin
   691.       validate_transfer(the_buffer, Q_operand);
   692.       validate_parity(the_buffer);
   693.       trap_invalid_instruction("PIF cannot be used on " & the_buffer.device_name);
   694.    end PIF;
   695.
   696.    procedure PIG (the_buffer  : in out IOC.device;
   697.                   Q_operand   : in KDF9.Q_register;
   698.                   set_offline : in Boolean) is
   699.       pragma Unreferenced(set_offline);
   700.    begin
   701.       validate_transfer(the_buffer, Q_operand);
   702.       validate_parity(the_buffer);
   703.       trap_invalid_instruction("PIG cannot be used on " & the_buffer.device_name);
   704.    end PIG;
   705.
   706.    procedure PIH (the_buffer  : in out IOC.device;
   707.                   Q_operand   : in KDF9.Q_register;
   708.                   set_offline : in Boolean) is
   709.       pragma Unreferenced(set_offline);
   710.    begin
   711.       validate_transfer(the_buffer, Q_operand);
   712.       validate_parity(the_buffer);
   713.       trap_invalid_instruction("PIH cannot be used on " & the_buffer.device_name);
   714.    end PIH;
   715.
   716.    procedure PMA (the_buffer  : in out IOC.device;
   717.                   Q_operand   : in KDF9.Q_register;
   718.                   set_offline : in Boolean) is
   719.       pragma Unreferenced(set_offline);
   720.    begin
   721.       validate_device(the_buffer, Q_operand);
   722.       validate_parity(the_buffer);
   723.       trap_invalid_instruction("PMA cannot be used on " & the_buffer.device_name);
   724.    end PMA;
   725.
   726.    procedure PMB (the_buffer  : in out IOC.device;
   727.                   Q_operand   : in KDF9.Q_register;
   728.                   set_offline : in Boolean) is
   729.       pragma Unreferenced(set_offline);
   730.    begin
   731.       validate_device(the_buffer, Q_operand);
   732.       validate_parity(the_buffer);
   733.    end PMB;
   734.
   735.    procedure PMC (the_buffer  : in out IOC.device;
   736.                   Q_operand   : in KDF9.Q_register;
   737.                   set_offline : in Boolean) is
   738.       pragma Unreferenced(set_offline);
   739.    begin
   740.       validate_device(the_buffer, Q_operand);
   741.       validate_parity(the_buffer);
   742.    end PMC;
   743.
   744.    procedure PMD (the_buffer  : in out IOC.device;
   745.                   Q_operand   : in KDF9.Q_register;
   746.                   set_offline : in Boolean) is
   747.       pragma Unreferenced(set_offline);
   748.    begin
   749.       validate_device(the_buffer, Q_operand);
   750.       validate_parity(the_buffer);
   751.       trap_invalid_instruction("PMD cannot be used on " & the_buffer.device_name);
   752.    end PMD;
   753.
   754.    procedure PME (the_buffer  : in out IOC.device;
   755.                   Q_operand   : in KDF9.Q_register;
   756.                   set_offline : in Boolean) is
   757.       pragma Unreferenced(set_offline);
   758.    begin
   759.       validate_device(the_buffer, Q_operand);
   760.       validate_parity(the_buffer);
   761.       trap_invalid_instruction("PME cannot be used on " & the_buffer.device_name);
   762.    end PME;
   763.
   764.    procedure PMF (the_buffer  : in out IOC.device;
   765.                   Q_operand   : in KDF9.Q_register;
   766.                   set_offline : in Boolean) is
   767.       pragma Unreferenced(set_offline);
   768.    begin
   769.       validate_device(the_buffer, Q_operand);
   770.       validate_parity(the_buffer);
   771.    end PMF;
   772.
   773.    procedure PMG (the_buffer  : in out IOC.device;
   774.                   Q_operand   : in KDF9.Q_register;
   775.                   set_offline : in Boolean) is
   776.       pragma Unreferenced(set_offline);
   777.    begin
   778.       validate_device(the_buffer, Q_operand);
   779.       validate_parity(the_buffer);
   780.       trap_invalid_instruction("PMG cannot be used on " & the_buffer.device_name);
   781.    end PMG;
   782.
   783.    procedure PMH (the_buffer  : in out IOC.device;
   784.                   Q_operand   : in KDF9.Q_register;
   785.                   set_offline : in Boolean) is
   786.       pragma Unreferenced(set_offline);
   787.    begin
   788.       validate_device(the_buffer, Q_operand);
   789.       validate_parity(the_buffer);
   790.       trap_invalid_instruction("PMH cannot be used on " & the_buffer.device_name);
   791.    end PMH;
   792.
   793.    procedure PMK (the_buffer  : in out IOC.device;
   794.                   Q_operand   : in KDF9.Q_register;
   795.                   set_offline : in Boolean) is
   796.       pragma Unreferenced(set_offline);
   797.    begin
   798.       validate_device(the_buffer, Q_operand);
   799.       validate_parity(the_buffer);
   800.       trap_invalid_instruction("PMK cannot be used on " & the_buffer.device_name);
   801.    end PMK;
   802.
   803.    procedure PML (the_buffer  : in out IOC.device;
   804.                   Q_operand   : in KDF9.Q_register;
   805.                   set_offline : in Boolean) is
   806.       pragma Unreferenced(set_offline);
   807.    begin
   808.       validate_device(the_buffer, Q_operand);
   809.       validate_parity(the_buffer);
   810.       trap_invalid_instruction("PML cannot be used on " & the_buffer.device_name);
   811.    end PML;
   812.
   813.    procedure POA (the_buffer  : in out IOC.device;
   814.                   Q_operand   : in KDF9.Q_register;
   815.                   set_offline : in Boolean) is
   816.       pragma Unreferenced(set_offline);
   817.    begin
   818.       validate_transfer(the_buffer, Q_operand);
   819.       validate_parity(the_buffer);
   820.       trap_invalid_instruction("POA cannot be used on " & the_buffer.device_name);
   821.    end POA;
   822.
   823.    procedure POB (the_buffer  : in out IOC.device;
   824.                   Q_operand   : in KDF9.Q_register;
   825.                   set_offline : in Boolean) is
   826.       pragma Unreferenced(set_offline);
   827.    begin
   828.       validate_transfer(the_buffer, Q_operand);
   829.       validate_parity(the_buffer);
   830.       trap_invalid_instruction("POB cannot be used on " & the_buffer.device_name);
   831.    end POB;
   832.
   833.    procedure POC (the_buffer  : in out IOC.device;
   834.                   Q_operand   : in KDF9.Q_register;
   835.                   set_offline : in Boolean) is
   836.       pragma Unreferenced(set_offline);
   837.    begin
   838.       validate_transfer(the_buffer, Q_operand);
   839.       validate_parity(the_buffer);
   840.       trap_invalid_instruction("POC cannot be used on " & the_buffer.device_name);
   841.    end POC;
   842.
   843.    procedure POD (the_buffer  : in out IOC.device;
   844.                   Q_operand   : in KDF9.Q_register;
   845.                   set_offline : in Boolean) is
   846.       pragma Unreferenced(set_offline);
   847.    begin
   848.       validate_transfer(the_buffer, Q_operand);
   849.       validate_parity(the_buffer);
   850.       trap_invalid_instruction("POD cannot be used on " & the_buffer.device_name);
   851.    end POD;
   852.
   853.    procedure POE (the_buffer  : in out IOC.device;
   854.                   Q_operand   : in KDF9.Q_register;
   855.                   set_offline : in Boolean) is
   856.       pragma Unreferenced(set_offline);
   857.    begin
   858.       validate_transfer(the_buffer, Q_operand);
   859.       validate_parity(the_buffer);
   860.       trap_invalid_instruction("POE cannot be used on " & the_buffer.device_name);
   861.    end POE;
   862.
   863.    procedure POF (the_buffer  : in out IOC.device;
   864.                   Q_operand   : in KDF9.Q_register;
   865.                   set_offline : in Boolean) is
   866.       pragma Unreferenced(set_offline);
   867.    begin
   868.       validate_transfer(the_buffer, Q_operand);
   869.       validate_parity(the_buffer);
   870.       trap_invalid_instruction("POF cannot be used on " & the_buffer.device_name);
   871.    end POF;
   872.
   873.    procedure POG (the_buffer  : in out IOC.device;
   874.                   Q_operand   : in KDF9.Q_register;
   875.                   set_offline : in Boolean) is
   876.       pragma Unreferenced(set_offline);
   877.    begin
   878.       validate_transfer(the_buffer, Q_operand);
   879.       validate_parity(the_buffer);
   880.       trap_invalid_instruction("POG cannot be used on " & the_buffer.device_name);
   881.    end POG;
   882.
   883.    procedure POH (the_buffer  : in out IOC.device;
   884.                   Q_operand   : in KDF9.Q_register;
   885.                   set_offline : in Boolean) is
   886.       pragma Unreferenced(set_offline);
   887.    begin
   888.       validate_transfer(the_buffer, Q_operand);
   889.       validate_parity(the_buffer);
   890.       trap_invalid_instruction("POH cannot be used on " & the_buffer.device_name);
   891.    end POH;
   892.
   893.    procedure POK (the_buffer  : in out IOC.device;
   894.                   Q_operand   : in KDF9.Q_register;
   895.                   set_offline : in Boolean) is
   896.       pragma Unreferenced(set_offline);
   897.    begin
   898.       validate_transfer(the_buffer, Q_operand);
   899.       validate_parity(the_buffer);
   900.       trap_invalid_instruction("POK cannot be used on " & the_buffer.device_name);
   901.    end POK;
   902.
   903.    procedure POL (the_buffer  : in out IOC.device;
   904.                   Q_operand   : in KDF9.Q_register;
   905.                   set_offline : in Boolean) is
   906.       pragma Unreferenced(set_offline);
   907.    begin
   908.       validate_transfer(the_buffer, Q_operand);
   909.       validate_parity(the_buffer);
   910.       trap_invalid_instruction("POL cannot be used on " & the_buffer.device_name);
   911.    end POL;
   912.
   913.    procedure close (the_buffer  : in out IOC.byte_device;
   914.                     the_action  : in String;
   915.                     the_amount  : in KDF9.word;
   916.                     the_quantum : in String) is
   917.    begin
   918.       if the_final_state_is_wanted and then
   919.             the_buffer.is_open and then
   920.                the_amount /= 0 then
   921.          if (the_buffer.number = 0) and not (API_logging_is_requested or the_log_is_wanted) then
   922.             output_line("");  -- Take a new line at the head of the list, for low-visibility modes.
   923.          end if;
   924.          output_line(the_buffer.device_name
   925.                    & " on buffer #"
   926.                    & oct_of(KDF9.Q_part(the_buffer.number), 2)
   927.                    & " "
   928.                    & the_action
   929.                    & KDF9.word'Image(the_amount)
   930.                    & " "
   931.                    & the_quantum
   932.                    & ".");
   933.       end if;
   934.       IOC.device(the_buffer).close;
   935.    end close;
   936.
   937.    function atomic_item_count (the_buffer : IOC.byte_device;
   938.                                Q_operand  : KDF9.Q_register)
   939.    return KDF9.word is
   940.       words : constant KDF9.Q_part := Q_operand.M - Q_operand.I + 1;
   941.    begin
   942.       if the_buffer.is_open then
   943.          return KDF9.word(words) * 8;
   944.       else
   945.          return 0;
   946.       end if;
   947.    end atomic_item_count;
   948.
   949.    procedure reattach (the_buffer   : in out IOC.byte_device;
   950.                        the_file     : in String) is
   951.    begin
   952.       reattach(the_buffer.stream, the_file, read_mode);
   953.    end reattach;
   954.
   955.    procedure deal_with_end_of_data (the_buffer : in out IOC.byte_device) is
   956.       BELL     : constant String := (1 => Character'Val(7));   -- Audible prompt
   957.       response : Character;
   958.    begin
   959.       output_line(BELL);
   960.       output_line("ee9: End of data for " & the_buffer.device_name & ". ");
   961.       prompt("To append a file give its identifying letter, or RETURN: ",
   962.              response,
   963.              default => '|');
   964.       case response is
   965.          when 'a' .. 'z' | 'A' .. 'Z' =>
   966.             reattach(the_buffer, the_buffer.device_name & response);
   967.          when others =>
   968.             the_buffer.is_abnormal := True;
   969.             raise end_of_stream;
   970.       end case;
   971.    end deal_with_end_of_data;
   972.
   973.    procedure initialize_byte_mode_gapping (the_buffer   : in out IOC.byte_device;
   974.                                            Q_operand    : in KDF9.Q_register;
   975.                                            set_offline  : in Boolean) is
   976.       time_needed : constant KDF9.microseconds
   977.                   := IO_elapsed_time(the_buffer, KDF9.word(Q_operand.M));
   978.    begin
   979.       require_positive_count(Q_operand.M);
   980.       start_timed_transfer(the_buffer, Q_operand, set_offline,
   981.                            busy_time => time_needed,
   982.                            is_DMAing => False);
   983.    end initialize_byte_mode_gapping;
   984.
   985.    procedure initialize_byte_mode_transfer (the_buffer   : in out IOC.byte_device;
   986.                                             Q_operand    : in KDF9.Q_register;
   987.                                             set_offline  : in Boolean) is
   988.       atomic_items : constant KDF9.word := atomic_item_count(the_buffer, Q_operand);
   989.       time_needed  : constant KDF9.microseconds := IO_elapsed_time(the_buffer, atomic_items);
   990.    begin
   991.       start_timed_transfer(the_buffer, Q_operand, set_offline,
   992.                            busy_time => time_needed,
   993.                            is_DMAing => True);
   994.    end initialize_byte_mode_transfer;
   995.
   996.    procedure get_char_from_stream (char       : out Character;
   997.                                    the_buffer : in out IOC.byte_device;
   998.                                    size       : in out KDF9.word) is
   999.    begin
  1000.       loop
  1001.          begin
  1002.             get_char(char, the_buffer.stream);
  1003.             return;
  1004.          exception
  1005.             when end_of_stream =>
  1006.                add_in_the_IO_CPU_time(the_buffer, size);
  1007.                correct_transfer_time(the_buffer, size);
  1008.                the_buffer.byte_count := the_buffer.byte_count + size;
  1009.                size := 0;
  1010.                deal_with_end_of_data(the_buffer);
  1011.          end;
  1012.       end loop;
  1013.    end get_char_from_stream;
  1014.
  1015.    overriding
  1016.    function IO_elapsed_time_total (the_buffer : IOC.unit_record_device)
  1017.    return KDF9.microseconds is
  1018.    begin
  1019.       return IO_elapsed_time(the_buffer, the_buffer.unit_count);
  1020.    end IO_elapsed_time_total;
  1021.
  1022.    overriding
  1023.    function atomic_item_count (the_buffer : IOC.unit_record_device;
  1024.                                Q_operand  : KDF9.Q_register)
  1025.    return KDF9.word is
  1026.       pragma Unreferenced(the_buffer);
  1027.       pragma Unreferenced(Q_operand);
  1028.    begin
  1029.       return 1;
  1030.    end atomic_item_count;
  1031.
  1032. end IOC;

Compiling: ../Source\ioc.ads
Source file time stamp: 2015-06-18 00:56:14
Compiled at: 2015-10-28 18:13:34

     1. -- ioc.ads
     2. --
     3. -- Emulation of the common functionality of a KDF9 IOC "buffer" (DMA channel),
     4. --    with fail-stop stubs for operations having device-specific behaviour.
     5. --
     6. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     7. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     8. --
     9. -- The ee9 program is free software; you can redistribute it and/or
    10. -- modify it under terms of the GNU General Public License as published
    11. -- by the Free Software Foundation; either version 3, or (at your option)
    12. -- any later version. This program is distributed in the hope that it
    13. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    14. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    15. -- See the GNU General Public License for more details. You should have
    16. -- received a copy of the GNU General Public License distributed with
    17. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    18. --
    19.
    20. with Ada.Finalization;
    21. --
    22. with KDF9;
    23. with Latin_1; pragma Unreferenced(Latin_1);
    24. with POSIX;
    25.
    26. private with exceptions;
    27. private with IO;
    28. private with tracing;
    29.
    30. use  Ada.Finalization;
    31. --
    32. use  KDF9;
    33.
    34. package IOC is
    35.
    36.    pragma Unsuppress(All_Checks);
    37.
    38.    -- N.B. the KDF9 'buffer' is a DMA controller in more modern terminology.
    39.
    40.    -- Each KDF9 buffer is externally characterized by:
    41.    --    its (absolute) number,
    42.    --    its (attached-device) kind, and
    43.    --    its unit (the number of that device within its kind).
    44.
    45.    -- A device of ND_kind is attached to a buffer with No Device connected.
    46.    -- If commanded, it performs a basic default action,
    47.    --   which is to cause a LIV interrupt in the case of transfers,
    48.    --     but is both benign and appropriate for all other operations.
    49.
    50.    type device_kind is
    51.       (CP_kind,  -- Card Punch
    52.        CR_kind,  -- Card Reader
    53.        DR_kind,  -- Drum
    54.        FD_kind,  -- Fixed Disc
    55.        FW_kind,  -- FlexoWriter (monitor typewriter)
    56.        GP_kind,  -- Graph Plotter (Calcomp 120' by 29.5" model)
    57.        LP_kind,  -- Line Printer
    58.        MT_kind,  -- Magnetic Tape
    59.        ST_kind,  -- Seven Track (IBM) magnetic Tape
    60.        TP_kind,  -- Tape Punch
    61.        TR_kind,  -- Tape Reader
    62.        ND_kind   -- No Device
    63.       );
    64.
    65.    subtype device_number is KDF9.Q_part range 0 .. 16;
    66.
    67. --
    68.    -- This is the root for all I/O device types.
    69. --
    70.
    71.    -- The quantum is the time, in µs, taken to transfer a basic datum.
    72.    -- For unit-record devices (CR, CP, LP) this is the card/line, respectively.
    73.    -- For other devices it is the KDF9 character.
    74.    -- A device is slow if it transfers data byte-by-byte; fast devices transfer whole words.
    75.
    76.    type device (
    77.                 number  : IOC.device_number;
    78.                 kind    : IOC.device_kind;
    79.                 unit    : KDF9.buffer_number;
    80.                 quantum : KDF9.microseconds;
    81.                 is_slow : Boolean
    82.                )
    83.    is abstract new Limited_Controlled with private;
    84.
    85.    no_fd : constant := -1;
    86.
    87.    -- Make the_buffer ready for I/O use by opening its associated file in the_mode;
    88.    --    or, if attaching, by using an already-open stream with an established fd.
    89.    procedure open (the_buffer : in out IOC.device'Class;
    90.                    the_mode   : in POSIX.access_mode;
    91.                    attaching  : in Boolean := False;
    92.                    to_fd      : in Integer := no_fd);
    93.
    94.    -- True iff the_buffer has been opened but not yet closed.
    95.    function is_open (the_buffer : IOC.device)
    96.    return Boolean;
    97.
    98.    -- A measure of the I/O volume enacted by the_buffer, so far.
    99.    function usage (the_buffer : IOC.device)
   100.    return KDF9.word;
   101.
   102.    -- Ensure that all output to the_buffer has been transmitted.
   103.    procedure flush (the_buffer : in out IOC.device);
   104.
   105.    -- Make the_buffer unavailable for further I/O use, after flushing if necessary.
   106.    procedure close (the_buffer : in out IOC.device);
   107.
   108.    -- A KDF9.logical_device_name is of the form XYu, where XY is a two-letter device-type
   109.    --    code (e.g., "LP" or "CR"); and u is the one- or two-digit logical unit number
   110.    --       of a device within its category.
   111.
   112.    function logical_device_name_of (the_buffer : IOC.device)
   113.    return KDF9.logical_device_name;
   114.
   115.    function logical_device_name_of (the_number : IOC.device_number)
   116.    return KDF9.logical_device_name;
   117.
   118.    -- The elapsed time for the I/O of the given number of atomic_items
   119.    --    which may be, e.g., bytes, or card images, or printer lines.
   120.    function IO_elapsed_time (the_buffer   : IOC.device;
   121.                              atomic_items : KDF9.word)
   122.    return KDF9.microseconds;
   123.
   124.    -- The total elapsed time taken, so far, by transfers on the attached device.
   125.    function IO_elapsed_time_total (the_buffer : IOC.device)
   126.    return KDF9.microseconds;
   127.
   128.
   129.    --
   130.    -- The CLOQq, SLOQq and TLOQq operations do NOT address a buffer,
   131.    --    and so are fully implemented elsewhere.
   132.    --
   133.
   134.    --
   135.    -- The INTQq, BUSYQq, PARQq and CTQq operations DO address a buffer,
   136.    --    but do NOT initiate an I/O transfer, and so are common to all devices.
   137.    --
   138.
   139.    -- INTQq
   140.    procedure INT (the_buffer  : in IOC.device'Class;
   141.                   Q_operand   : in KDF9.Q_register;
   142.                   set_offline : in Boolean);
   143.
   144.    -- BUSYQq
   145.    procedure BUSY (the_buffer  : in IOC.device'Class;
   146.                    Q_operand   : in KDF9.Q_register;
   147.                    set_offline : in Boolean;
   148.                    result      : out KDF9.word);
   149.
   150.    -- PARQq
   151.    procedure PAR (the_buffer   : in out IOC.device'Class;
   152.                    Q_operand   : in KDF9.Q_register;
   153.                    set_offline : in Boolean;
   154.                    result      : out KDF9.word);
   155.
   156.    -- CTQq
   157.    procedure CTQ (the_buffer  : in out IOC.device'Class;
   158.                   Q_operand   : in KDF9.Q_register;
   159.                   set_offline : in Boolean);
   160.
   161.    -- These KDF9 data-transfer operations must be overridden for non-trivial functionality.
   162.    -- Invoking any of them raises a LIV exception. This exactly mirrors the action of the
   163.    --    KDF9 in causing a LIV interrupt when an invalid operation was applied to a device.
   164.    -- A device without some of these operations inherits them from this list and so
   165.    --    implements correctly the original semantics of the KDF9.
   166.
   167.    --
   168.    -- The PI* are input operations.
   169.    --
   170.
   171.    -- PIAQq
   172.    procedure PIA (the_buffer  : in out IOC.device;
   173.                   Q_operand   : in KDF9.Q_register;
   174.                   set_offline : in Boolean);
   175.
   176.    -- PIBQq
   177.    procedure PIB (the_buffer  : in out IOC.device;
   178.                   Q_operand   : in KDF9.Q_register;
   179.                   set_offline : in Boolean);
   180.
   181.    -- PICQq
   182.    procedure PIC (the_buffer  : in out IOC.device;
   183.                   Q_operand   : in KDF9.Q_register;
   184.                   set_offline : in Boolean);
   185.
   186.    -- PIDQq
   187.    procedure PID (the_buffer  : in out IOC.device;
   188.                   Q_operand   : in KDF9.Q_register;
   189.                   set_offline : in Boolean);
   190.
   191.    -- PIEQq
   192.    procedure PIE (the_buffer  : in out IOC.device;
   193.                   Q_operand   : in KDF9.Q_register;
   194.                   set_offline : in Boolean);
   195.
   196.    -- PIFQq
   197.    procedure PIF (the_buffer  : in out IOC.device;
   198.                   Q_operand   : in KDF9.Q_register;
   199.                   set_offline : in Boolean);
   200.
   201.    -- PIGQq
   202.    procedure PIG (the_buffer  : in out IOC.device;
   203.                   Q_operand   : in KDF9.Q_register;
   204.                   set_offline : in Boolean);
   205.
   206.    -- PIHQq
   207.    procedure PIH (the_buffer  : in out IOC.device;
   208.                   Q_operand   : in KDF9.Q_register;
   209.                   set_offline : in Boolean);
   210.
   211.    --
   212.    -- The PM* are device-status operations.
   213.    --
   214.
   215.    -- PMAQq
   216.    procedure PMA (the_buffer  : in out IOC.device;
   217.                   Q_operand   : in KDF9.Q_register;
   218.                   set_offline : in Boolean);
   219.
   220.    -- PMBQq
   221.    procedure PMB (the_buffer  : in out IOC.device;
   222.                   Q_operand   : in KDF9.Q_register;
   223.                   set_offline : in Boolean);
   224.
   225.    -- PMCQq
   226.    procedure PMC (the_buffer  : in out IOC.device;
   227.                   Q_operand   : in KDF9.Q_register;
   228.                   set_offline : in Boolean);
   229.
   230.    -- PMDQq
   231.    procedure PMD (the_buffer  : in out IOC.device;
   232.                   Q_operand   : in KDF9.Q_register;
   233.                   set_offline : in Boolean);
   234.
   235.    -- PMEQq
   236.    procedure PME (the_buffer  : in out IOC.device;
   237.                   Q_operand   : in KDF9.Q_register;
   238.                   set_offline : in Boolean);
   239.
   240.    -- PMFQq
   241.    procedure PMF (the_buffer  : in out IOC.device;
   242.                   Q_operand   : in KDF9.Q_register;
   243.                   set_offline : in Boolean);
   244.
   245.    -- PMGQq
   246.    procedure PMG (the_buffer  : in out IOC.device;
   247.                   Q_operand   : in KDF9.Q_register;
   248.                   set_offline : in Boolean);
   249.
   250.    -- PMHQq
   251.    procedure PMH (the_buffer  : in out IOC.device;
   252.                   Q_operand   : in KDF9.Q_register;
   253.                   set_offline : in Boolean);
   254.
   255.    -- PMGQq
   256.    procedure PMK (the_buffer  : in out IOC.device;
   257.                   Q_operand   : in KDF9.Q_register;
   258.                   set_offline : in Boolean);
   259.
   260.    -- PMHQq
   261.    procedure PML (the_buffer  : in out IOC.device;
   262.                   Q_operand   : in KDF9.Q_register;
   263.                   set_offline : in Boolean);
   264.
   265.    --
   266.    -- The PO* are output operations.
   267.    --
   268.
   269.    -- POAQq
   270.    procedure POA (the_buffer  : in out IOC.device;
   271.                   Q_operand   : in KDF9.Q_register;
   272.                   set_offline : in Boolean);
   273.
   274.    -- POBQq
   275.    procedure POB (the_buffer  : in out IOC.device;
   276.                   Q_operand   : in KDF9.Q_register;
   277.                   set_offline : in Boolean);
   278.
   279.    -- POCQq
   280.    procedure POC (the_buffer  : in out IOC.device;
   281.                   Q_operand   : in KDF9.Q_register;
   282.                   set_offline : in Boolean);
   283.
   284.    -- PODQq
   285.    procedure POD (the_buffer  : in out IOC.device;
   286.                   Q_operand   : in KDF9.Q_register;
   287.                   set_offline : in Boolean);
   288.
   289.    -- POEQq
   290.    procedure POE (the_buffer  : in out IOC.device;
   291.                   Q_operand   : in KDF9.Q_register;
   292.                   set_offline : in Boolean);
   293.
   294.    -- POFQq
   295.    procedure POF (the_buffer  : in out IOC.device;
   296.                   Q_operand   : in KDF9.Q_register;
   297.                   set_offline : in Boolean);
   298.
   299.    -- POGQq
   300.    procedure POG (the_buffer  : in out IOC.device;
   301.                   Q_operand   : in KDF9.Q_register;
   302.                   set_offline : in Boolean);
   303.
   304.    -- POHQq
   305.    procedure POH (the_buffer  : in out IOC.device;
   306.                   Q_operand   : in KDF9.Q_register;
   307.                   set_offline : in Boolean);
   308.
   309.    -- POKQq
   310.    procedure POK (the_buffer  : in out IOC.device;
   311.                   Q_operand   : in KDF9.Q_register;
   312.                   set_offline : in Boolean);
   313.
   314.    -- POLQq
   315.    procedure POL (the_buffer  : in out IOC.device;
   316.                   Q_operand   : in KDF9.Q_register;
   317.                   set_offline : in Boolean);
   318.
   319.
   320. --
   321.    -- The byte_device type is the root type for all byte-mode I/O device types.
   322. --
   323.
   324.    type byte_device is abstract new IOC.device with private;
   325.
   326.    -- Change the file associated with a device.
   327.    procedure reattach (the_buffer   : in out IOC.byte_device;
   328.                        the_file     : in String);
   329.
   330.    -- Allow a file to be appended to the device when EOF is detected.
   331.    -- If the user does not specify such a file, set the device abnormal.
   332.    procedure deal_with_end_of_data (the_buffer : in out IOC.byte_device);
   333.
   334.
   335. --
   336.    -- The unit_record_device type is the root type for all unit-record I/O device types.
   337. --
   338.
   339.    type unit_record_device is abstract new IOC.byte_device with private;
   340.
   341.
   342. --
   343.    -- The buffer_configuration type enables the dynamic setting-up of an IOC configuration.
   344. --
   345.
   346.    type device_class_access  is access all IOC.device'Class;
   347.
   348.    type buffer_configuration is array (KDF9.buffer_number) of IOC.device_class_access;
   349.
   350.    -- These are the buffer numbers for the devices in this configuration.
   351.
   352.    ND0_number : constant := 16;          -- No Device (not in configuration)
   353.
   354.    FW0_number : constant := 0;            -- FlexoWriter (monitor typewriter)
   355.    TR0_number : constant := 1;            -- Tape Reader Unit 0
   356.    TR1_number : constant := 2;            -- Tape Reader Unit 1
   357.    TP1_number : constant := 3;            -- Tape Punch Unit 1 (sic)
   358.    GP0_number : constant := 3;            -- Graph Plotter, on the TP1 buffer
   359.    TP0_number : constant := 4;            -- Tape Punch Unit 0 (sic)
   360.    LP0_number : constant := 5;            -- Line Printer
   361.    CR0_number : constant := 6;            -- Card Reader
   362.    MT0_number : constant := 7;            -- Magnetic Tape Unit 0
   363.    CP0_number : constant := 15;           -- Card Punch
   364.    DR0_number : constant := ND0_number;   -- Drum
   365.    ST0_number : constant := ND0_number;   -- Seven track IBM magnetic Tape
   366.    -- FD0_number is defined in KDF9       -- Fixed Disc
   367.
   368.    -- These are the I/O devices installed in this configuration.
   369.    -- The configuration is initialised elsewhere to avoid cyclical type dependencies.
   370.
   371.    buffer : buffer_configuration;
   372.
   373. --
   374.    -- These operations are used by Directors to manage device allocation to problem programs.
   375. --
   376.
   377.    procedure set_state_of (the_buffer : in device_class_access;
   378.                            allocated  : in Boolean);
   379.
   380.    function is_unallocated (the_buffer : device_class_access)  -- N.B. is_UNallocated.
   381.    return Boolean;
   382.
   383. --
   384.    -- These buffer-implementation operations are used outside IOC and apply to all device types.
   385. --
   386.
   387.    -- Complete all extant transfers, then Finalize each buffer.
   388.    procedure finalize_all_KDF9_buffers;
   389.
   390.    -- Advance the elapsed time to a point after all extant transfer have terminated.
   391.    procedure complete_all_extant_transfers;
   392.
   393.    -- Complete any terminated transfer operations and take any needed interrupts.
   394.    procedure act_on_pending_interrupts;
   395.
   396.    -- A LOV interupt caused by an attempted store access must arrange
   397.    --    for the interrupted instruction to be resumed.
   398.    -- In boot mode, signal the LOV interrupt to Director.
   399.    -- In other modes, advance the elapsed time to the end-of-transfer time
   400.    --    for the locked-out address, then act on pending interrupts.
   401.    procedure handle_a_main_store_lockout (address : in KDF9.Q_part);
   402.
   403.    -- Take note of the start of a transfer.
   404.    procedure start_timed_transfer (the_buffer  : in out IOC.device'Class;
   405.                                    Q_operand   : in KDF9.Q_register;
   406.                                    set_offline : in Boolean;
   407.                                    busy_time   : in KDF9.microseconds;
   408.                                    is_DMAing   : in Boolean := True);
   409.
   410. private
   411.
   412.    -- The following packages are hereby made available to all children of IOC.
   413.    use exceptions; pragma Warnings(Off, exceptions);
   414.    use IO;         pragma Warnings(Off, IO);
   415.    use tracing;    pragma Warnings(Off, tracing);
   416.    use POSIX;
   417.
   418. --
   419.    -- Completing the root for all I/O device types.
   420. --
   421.
   422.    type device (
   423.                 number  : IOC.device_number;
   424.                 kind    : IOC.device_kind;
   425.                 unit    : KDF9.buffer_number;
   426.                 quantum : KDF9.microseconds;
   427.                 is_slow : Boolean
   428.                )
   429.    is abstract new Limited_Controlled with
   430.                record
   431.                   is_abnormal,
   432.                   is_busy,
   433.                   is_DMAing,
   434.                   is_offline,
   435.                   is_allocated,
   436.                   is_for_Director : Boolean := False;
   437.                   initiation_time : KDF9.microseconds := KDF9.microseconds'Last;
   438.                   transfer_time   : KDF9.microseconds := KDF9.microseconds'Last;
   439.                   completion_time : KDF9.microseconds := KDF9.microseconds'Last;
   440.                   control_word    : KDF9.Q_register;
   441.                   decoded_order   : KDF9.decoded_order;
   442.                   device_name     : KDF9.logical_device_name;
   443.                   order_address   : KDF9.code_point;
   444.                   order_count     : KDF9.order_counter;
   445.                   priority_level  : KDF9.priority;
   446.                   stream          : IO.stream;
   447.                end record;
   448.
   449.    overriding
   450.    procedure Initialize (the_buffer : in out IOC.device);
   451.
   452.    overriding
   453.    procedure Finalize (the_buffer : in out IOC.device);
   454.
   455. --
   456.    -- Completing the root for all byte-mode I/O device types.
   457. --
   458.
   459.    type byte_device is abstract new IOC.device with
   460.       record
   461.          byte_count : KDF9.word := 0;
   462.       end record;
   463.
   464.    procedure close (the_buffer  : in out IOC.byte_device;
   465.                     the_action  : in String;
   466.                     the_amount  : in KDF9.word;
   467.                     the_quantum : in String);
   468.
   469.    -- The number of timed transfer units in the designated core-store area.
   470.    -- In the case of unit-record devices, such as card readers and line printers,
   471.    --    this is the number of unit records (cards, or lines, respectively).
   472.    -- In all other cases it is the number of characters in the designated core-store area.
   473.    function atomic_item_count (the_buffer : IOC.byte_device;
   474.                                Q_operand  : KDF9.Q_register)
   475.    return KDF9.word;
   476.
   477.    -- Check the IO parameters and the buffer state, and handle any old lockout.
   478.    -- Set the new buffer state, and project the next interrupt time.
   479.    procedure initialize_byte_mode_gapping (the_buffer   : in out IOC.byte_device;
   480.                                            Q_operand    : in KDF9.Q_register;
   481.                                            set_offline  : in Boolean);
   482.
   483.    -- Check the IO parameters and the buffer state, and handle any old lockout.
   484.    -- Set the new buffer state, and project the next interrupt time.
   485.    procedure initialize_byte_mode_transfer (the_buffer   : in out IOC.byte_device;
   486.                                             Q_operand    : in KDF9.Q_register;
   487.                                             set_offline  : in Boolean);
   488.
   489.    -- Read a character from the stream and deal with any input file concatenation.
   490.    procedure get_char_from_stream (char       : out Character;
   491.                                    the_buffer : in out IOC.byte_device;
   492.                                    size       : in out KDF9.word);
   493.
   494.
   495. --
   496.    -- Completing the root the root type for all unit-record I/O device types.
   497. --
   498.
   499.    type unit_record_device is abstract new IOC.byte_device with
   500.       record
   501.          unit_count : KDF9.word := 0;
   502.       end record;
   503.
   504.    overriding
   505.    function IO_elapsed_time_total (the_buffer : IOC.unit_record_device)
   506.    return KDF9.microseconds;
   507.
   508.    overriding
   509.    function atomic_item_count (the_buffer : IOC.unit_record_device;
   510.                                Q_operand  : KDF9.Q_register)
   511.    return KDF9.word;
   512.
   513. --
   514. --
   515.    -- Operations, used only within the IOC hierarchy, that apply to all device types.
   516. --
   517. --
   518.
   519.    -- Mask off the buffer number in the Q_operand.C; to remove any disc parameter.
   520.    function canonical (Q_operand : KDF9.Q_register)
   521.    return KDF9.Q_register;
   522.
   523.
   524.    -- Check that the_buffer is online, validly identified by the Q_operand,
   525.    --    and that access to it is permitted by the (perhaps simulated) Director;
   526.    --       LIV if not.
   527.    procedure validate_device (the_buffer : in IOC.device'Class;
   528.                               Q_operand  : in KDF9.Q_register);
   529.
   530.    -- Check that the buffer for the_device is unused, then set it to the_device.
   531.    procedure install (the_device : in out IOC.device'Class);
   532.
   533.    -- Check that the device and the transfer address bounds are valid;
   534.    --    LIV if not.
   535.    procedure validate_transfer (the_buffer : in IOC.device'Class;
   536.                                 Q_operand  : in KDF9.Q_register);
   537.
   538.    -- LIV if the_buffer is in the abnormal state.
   539.    procedure validate_parity (the_buffer : in IOC.device'Class);
   540.
   541.    -- When the real duration of a variable-length transfer is known,
   542.    --    its completion time can be made accurate by giving its actual_time.
   543.    -- correct_transfer_time must be called before finalize_transfer is called.
   544.
   545.    procedure correct_transfer_time (the_buffer  : in out IOC.device'Class;
   546.                                     actual_time : in KDF9.microseconds);
   547.
   548.    procedure correct_transfer_time (the_buffer    : in out IOC.device'Class;
   549.                                     actual_length : in KDF9.word);
   550.
   551.    -- If the buffer has a terminated transfer, clear its lockouts, reset its state,
   552.    --    update the PHUs, and demand an EDT or PR interrupt as needed.
   553.    procedure finalize_transfer (the_buffer : in out IOC.device'Class;
   554.                                 need_EDT,
   555.                                 need_PR    : out Boolean);
   556.
   557.    -- In boot mode, signal the LOV interrupt to Director.
   558.    -- In other modes, advance the elapsed time to the next-interrupt time,
   559.    --    and suppress the LOV by simulating an earlier end of transfer.
   560.    procedure handle_a_buffer_lockout (the_buffer : in IOC.device'Class);
   561.
   562.    -- Account for the CPU (i.e., core store) time taken by the buffer's DMA cycles.
   563.    procedure add_in_the_IO_CPU_time (IO_CPU_time : in KDF9.microseconds);
   564.
   565.    procedure add_in_the_IO_CPU_time (the_buffer  : in IOC.device'Class;
   566.                                      bytes_moved : in KDF9.word);
   567.
   568.    -- LIV if the repetition count is negative.
   569.    procedure require_nonnegative_count (count : in KDF9.Q_part);
   570.
   571.    -- LIV if the repetition count is negative or zero.
   572.    procedure require_positive_count (count : in KDF9.Q_part);
   573.
   574.    -- Account for the CPU time taken by the buffer in setting store lockouts.
   575.    procedure add_in_the_IO_lockout_CPU_time (Q_operand : in KDF9.Q_register);
   576.
   577. end IOC;

 1032 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-two_shift.adb
Source file time stamp: 2015-06-18 00:56:18
Compiled at: 2015-10-28 18:13:40

     1. -- ioc-byte_mode-two_shift.adb
     2. --
     3. -- Emulation of the common functionality of a 2-case (Normal/Shift) buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9.store;
    20.
    21. use  KDF9.store;
    22.
    23. package body IOC.two_shift is
    24.
    25.    overriding
    26.    procedure Finalize (the_device : in out two_shift.device) is
    27.    begin
    28.       close(the_device, "transferred", the_device.byte_count, "character(s)");
    29.    end Finalize;
    30.
    31.    procedure do_input_housekeeping (the_device : in out two_shift.device;
    32.                                     read_in,
    33.                                     stored     : in KDF9.word) is
    34.    begin
    35.       if read_in > 0 then
    36.          add_in_the_IO_CPU_time(the_device, stored);
    37.       end if;
    38.       correct_transfer_time(the_device, read_in);
    39.       the_device.byte_count := the_device.byte_count + read_in;
    40.    end do_input_housekeeping;
    41.
    42.    procedure get_symbols (the_device    : in out two_shift.device;
    43.                           Q_operand     : in KDF9.Q_register;
    44.                           reading_to_EM : in Boolean) is
    45.       start_address : constant KDF9.address := Q_operand.I;
    46.       end_address   : constant KDF9.address := Q_operand.M;
    47.       fill   : KDF9.word := 0;
    48.       size   : KDF9.word := 0;
    49.       symbol : KDF9.symbol;
    50.       char   : Character;
    51.    begin
    52.       validate_range_access(start_address, end_address);
    53.    word_loop:
    54.       for w in start_address .. end_address loop
    55.          store_word(0, w);
    56.          for c in KDF9.symbol_number'Range loop
    57.             get_char_from_stream(char, the_device, size);
    58.             size := size + 1;
    59.             if char = KDF9.W_F then
    60.                -- Filler was suppressed on normal input from the slow devices.
    61.                fill := fill + 1;
    62.             elsif case_of(char) /= both and case_of(char) /= the_device.current_case then
    63.                store_symbol(CN_TR(next_case(the_device.current_case)), w, c);
    64.                the_device.current_case := the_device.current_case xor 1;
    65.                back_off(the_device.stream);
    66.             else
    67.                symbol := CN_TR(char) or CS_TR(char);
    68.                store_symbol(symbol, w, c);
    69.                if reading_to_EM and symbol = KDF9.End_Message then
    70.                   for d in 1 .. 7-c loop
    71.                      store_symbol(KDF9.Blank_Space, w, c+d);
    72.                   end loop;
    73.                   exit word_loop;
    74.                end if;
    75.             end if;
    76.          end loop;
    77.       end loop word_loop;
    78.       do_input_housekeeping(the_device, read_in => size, stored => size-fill);
    79.    exception
    80.       when end_of_stream =>
    81.          flush(the_device.stream);
    82.          do_input_housekeeping(the_device, read_in => size, stored => size-fill);
    83.    end get_symbols;
    84.
    85.    procedure read (the_device : in out two_shift.device;
    86.                    Q_operand  : in KDF9.Q_register) is
    87.    begin
    88.       get_symbols(the_device, Q_operand, reading_to_EM => False);
    89.    end read;
    90.
    91.    procedure read_to_EM (the_device : in out two_shift.device;
    92.                          Q_operand  : in KDF9.Q_register) is
    93.    begin
    94.       get_symbols(the_device, Q_operand, reading_to_EM => True);
    95.    end read_to_EM;
    96.
    97.    procedure get_words (the_device    : in out two_shift.device;
    98.                         Q_operand     : in KDF9.Q_register;
    99.                         reading_to_EM : in Boolean) is
   100.       start_address : constant KDF9.address := Q_operand.I;
   101.       end_address   : constant KDF9.address := Q_operand.M;
   102.       size : KDF9.word := 0;
   103.       word : KDF9.word;
   104.       char : Character;
   105.    begin
   106.       validate_range_access(start_address, end_address);
   107.       for w in start_address .. end_address loop
   108.          get_char_from_stream(char, the_device, size);
   109.          word := KDF9.word(Character'Pos(char));
   110.          size := size + 1;
   111.          store_word(word, w);
   112.       exit when reading_to_EM and (word and 8#77#) = KDF9.word(KDF9.End_Message);
   113.       end loop;
   114.       do_input_housekeeping(the_device, read_in => size, stored => size);
   115.    exception
   116.       when end_of_stream =>
   117.          flush(the_device.stream);
   118.          do_input_housekeeping(the_device, read_in => size, stored => size);
   119.    end get_words;
   120.
   121.    procedure words_read (the_device : in out two_shift.device;
   122.                          Q_operand  : in KDF9.Q_register) is
   123.    begin
   124.       get_words(the_device, Q_operand, reading_to_EM => False);
   125.    end words_read;
   126.
   127.    procedure words_read_to_EM (the_device : in out two_shift.device;
   128.                                Q_operand  : in KDF9.Q_register) is
   129.    begin
   130.       get_words(the_device, Q_operand, reading_to_EM => True);
   131.    end words_read_to_EM;
   132.
   133.    procedure do_output_housekeeping (the_device : in out two_shift.device;
   134.                                      written,
   135.                                      fetched    : in KDF9.word) is
   136.    begin
   137.       flush(the_device.stream);
   138.       add_in_the_IO_CPU_time(the_device, fetched);
   139.       correct_transfer_time(the_device, written);
   140.       the_device.byte_count := the_device.byte_count + fetched;
   141.    end do_output_housekeeping;
   142.
   143.    procedure put_symbols (the_device    : in out two_shift.device;
   144.                           Q_operand     : in KDF9.Q_register;
   145.                           writing_to_EM : in Boolean) is
   146.       start_address : constant KDF9.address := Q_operand.I;
   147.       end_address   : constant KDF9.address := Q_operand.M;
   148.       fill   : KDF9.word := 0;
   149.       size   : KDF9.word := 0;
   150.       symbol : KDF9.symbol;
   151.       char   : Character;
   152.    begin
   153.       validate_range_access(start_address, end_address);
   154.    word_loop:
   155.       for w in start_address .. end_address loop
   156.          for c in KDF9.symbol_number'Range loop
   157.             symbol := fetch_symbol(w, c);
   158.             size := size + 1;
   159.             if symbol = KDF9.Word_Filler then
   160.                -- Filler was suppressed on normal output to the slow devices.
   161.                fill := fill + 1;
   162.             elsif symbol = KDF9.Case_Shift then
   163.                the_device.current_case := KDF9.Case_Shift;
   164.             elsif  symbol = KDF9.Case_Normal then
   165.                the_device.current_case := KDF9.Case_Normal;
   166.             else
   167.                if the_device.current_case = KDF9.Case_Normal then
   168.                   char := TP_CN(symbol);
   169.                else
   170.                   char := TP_CS(symbol);
   171.                end if;
   172.                put_char(char, the_device.stream);
   173.                exit word_loop when writing_to_EM and symbol = KDF9.End_Message;
   174.             end if;
   175.          end loop;
   176.       end loop word_loop;
   177.       do_output_housekeeping(the_device, written => size-fill, fetched => size);
   178.    exception
   179.       when end_of_stream =>
   180.          do_output_housekeeping(the_device, written => size-fill, fetched => size);
   181.    end put_symbols;
   182.
   183.    procedure write (the_device : in out two_shift.device;
   184.                     Q_operand  : in KDF9.Q_register) is
   185.    begin
   186.       put_symbols(the_device, Q_operand, writing_to_EM => False);
   187.    end write;
   188.
   189.    procedure write_to_EM (the_device : in out two_shift.device;
   190.                           Q_operand  : in KDF9.Q_register) is
   191.    begin
   192.       put_symbols(the_device, Q_operand, writing_to_EM => True);
   193.    end write_to_EM;
   194.
   195.    procedure put_words (the_device    : in out two_shift.device;
   196.                         Q_operand     : in KDF9.Q_register;
   197.                         writing_to_EM : in Boolean) is
   198.       start_address : constant KDF9.address := Q_operand.I;
   199.       end_address   : constant KDF9.address := Q_operand.M;
   200.       size : KDF9.word := 0;
   201.       word : KDF9.word;
   202.    begin
   203.       validate_range_access(start_address, end_address);
   204.       for w in start_address .. end_address loop
   205.          word := fetch_word(w) and 8#377#;
   206.          put_byte(Character'Val(word), the_device.stream);
   207.          size := size + 1;
   208.       exit when writing_to_EM and (word and 8#77#) = KDF9.word(KDF9.End_Message);
   209.       end loop;
   210.       do_output_housekeeping(the_device, written => size, fetched => size);
   211.    exception
   212.       when end_of_stream =>
   213.          do_output_housekeeping(the_device, written => size, fetched => size);
   214.    end put_words;
   215.
   216.    procedure words_write (the_device : in out two_shift.device;
   217.                           Q_operand  : in KDF9.Q_register) is
   218.    begin
   219.       put_words(the_device, Q_operand, writing_to_EM => False);
   220.    end words_write;
   221.
   222.    procedure words_write_to_EM (the_device : in out two_shift.device;
   223.                                 Q_operand  : in KDF9.Q_register) is
   224.    begin
   225.       put_words(the_device, Q_operand, writing_to_EM => True);
   226.    end words_write_to_EM;
   227.
   228.    procedure set_case (the_device  : in out two_shift.device;
   229.                        the_setting : in KDF9.letter_case := Case_Normal) is
   230.    begin
   231.       the_device.current_case := the_setting;
   232.    end set_case;
   233.
   234. end IOC.two_shift;

Compiling: ../Source\ioc-two_shift.ads
Source file time stamp: 2015-06-18 00:56:16
Compiled at: 2015-10-28 18:13:40

     1. -- ioc-byte_mode-two_shift.ads
     2. --
     3. -- Emulation of the common functionality of a 2-case (Normal/Shift) buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with IOC;
    20. with Latin_1; pragma Unreferenced(Latin_1);
    21.
    22. package IOC.two_shift is
    23.
    24.    pragma Unsuppress(All_Checks);
    25.
    26.    --
    27.    -- Abstract common functionality of Case Normal / Case Shift devices, e.g.,
    28.    --    the paper tape reader (TR), punch (TP) and console Flexowriter (FW).
    29.    --
    30.    type device is abstract new IOC.byte_device with private;
    31.
    32.    procedure set_case (the_device  : in out two_shift.device;
    33.                        the_setting : in KDF9.letter_case := Case_Normal);
    34.
    35. private
    36.
    37.    type device is abstract new IOC.byte_device with
    38.       record
    39.          current_case : KDF9.letter_case range Case_Shift .. Case_Normal := Case_Normal;
    40.       end record;
    41.
    42.    overriding
    43.    procedure Finalize (the_device : in out two_shift.device);
    44.
    45.    procedure do_input_housekeeping (the_device : in out two_shift.device;
    46.                                    read_in,
    47.                                    stored     : in KDF9.word);
    48.
    49.    procedure do_output_housekeeping (the_device : in out two_shift.device;
    50.                                     written,
    51.                                     fetched    : in KDF9.word);
    52.
    53.    procedure write (the_device : in out two_shift.device;
    54.                     Q_operand  : in KDF9.Q_register);
    55.
    56.    procedure read (the_device : in out two_shift.device;
    57.                    Q_operand  : in KDF9.Q_register);
    58.
    59.    procedure write_to_EM (the_device : in out two_shift.device;
    60.                           Q_operand  : in KDF9.Q_register);
    61.
    62.    procedure read_to_EM (the_device : in out two_shift.device;
    63.                          Q_operand  : in KDF9.Q_register);
    64.
    65.    procedure words_write (the_device : in out two_shift.device;
    66.                           Q_operand  : in KDF9.Q_register);
    67.
    68.    procedure words_read (the_device : in out two_shift.device;
    69.                          Q_operand  : in KDF9.Q_register);
    70.
    71.    procedure words_write_to_EM (the_device : in out two_shift.device;
    72.                                 Q_operand  : in KDF9.Q_register);
    73.
    74.    procedure words_read_to_EM (the_device : in out two_shift.device;
    75.                                Q_operand  : in KDF9.Q_register);
    76.
    77. end IOC.two_shift;

 234 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-two_shift-tr.adb
Source file time stamp: 2015-06-18 00:56:18
Compiled at: 2015-10-28 18:13:41

     1. -- ioc-two_shift-tr.adb
     2. --
     3. -- Emulation of a paper tape reader buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with IO;
    20. with IOC; pragma Elaborate_All(IOC);
    21. with IOC.two_shift;
    22. with KDF9.TOD_clock;
    23. with KDF9.Directors;
    24. with KDF9.store;
    25. with settings;
    26.
    27. pragma Unreferenced(IO);
    28.
    29. use  KDF9.TOD_clock;
    30. use  KDF9.store;
    31. use  settings;
    32.
    33. package body IOC.two_shift.TR is
    34.
    35.    overriding
    36.    procedure Initialize (the_TR     : in out TR.device) is
    37.    begin
    38.       if the_TR.unit = 0 then
    39.          -- Use the emulator's standard input.
    40.          open(the_TR, read_mode, attaching => True, to_fd => 0);
    41.       else
    42.          -- Open the associated file.
    43.          open(the_TR, read_mode, attaching => False);
    44.       end if;
    45.       the_TR.current_case := KDF9.Case_Normal;
    46.    end Initialize;
    47.
    48.    overriding
    49.    procedure Finalize (the_TR : in out TR.device) is
    50.    begin
    51.       close(the_TR, "read", the_TR.byte_count, "character(s)");
    52.    end Finalize;
    53.
    54.    -- Read 8-bit bytes, and pack into words without transformation.
    55.    procedure read_bytes_verbatim (the_TR    : in out TR.device;
    56.                                          Q_operand : in KDF9.Q_register) is
    57.       start_address : constant KDF9.address := Q_operand.I;
    58.       end_address   : constant KDF9.address := Q_operand.M;
    59.       size  : KDF9.word := 0;
    60.       w     : KDF9.code_location := KDF9.code_location(start_address);
    61.       s     : KDF9.syllable_code range 0 .. 5 := 0;
    62.       char  : Character;
    63.       octet : KDF9.syllable;
    64.    begin
    65.       loop
    66.          get_byte(char, the_TR.stream);
    67.          octet := KDF9.syllable(Character'Pos(char));
    68.          store_syllable(octet, (s, w));
    69.          if s < 5 then
    70.             s := s + 1;
    71.          else
    72.             s := 0;
    73.             w := w + 1;
    74.          end if;
    75.          size := size + 1;
    76.          exit when w > KDF9.code_location(end_address);
    77.       end loop;
    78.       add_in_the_IO_CPU_time(the_TR, size);
    79.       correct_transfer_time(the_TR, KDF9.word'(0));
    80.    exception
    81.       when end_of_stream =>
    82.          add_in_the_IO_CPU_time(the_TR, size);
    83.          correct_transfer_time(the_TR, KDF9.word'(0));
    84.    end read_bytes_verbatim;
    85.
    86.    -- Read 8-bit bytes, compress to 6-bit characters, and pack into words.
    87.    procedure read_orders (the_TR    : in out TR.device;
    88.                           Q_operand : in KDF9.Q_register) is
    89.       start_address : constant KDF9.address := Q_operand.I;
    90.       end_address   : constant KDF9.address := Q_operand.M;
    91.       size   : KDF9.word := 0;
    92.       w      : KDF9.address := start_address;
    93.       c      : KDF9.symbol_number := 0;
    94.       char   : Character;
    95.       octet  : KDF9.syllable;
    96.       symbol : KDF9.symbol;
    97.    begin
    98.       validate_range_access(start_address, end_address);
    99.    word_loop:
   100.       loop
   101.          loop
   102.             get_byte(char, the_TR.stream);
   103.          exit when Character'Pos(char) /= 0 and Character'Pos(char) /= 255;
   104.          end loop;
   105.          octet  := KDF9.syllable(Character'Pos(char));
   106.          symbol := KDF9.symbol((octet and 16#6_0#)/2 or (octet and 16#F#));
   107.          store_symbol(symbol, w, c);
   108.          if c < KDF9.symbol_number'Last then
   109.             c := c + 1;
   110.          else
   111.             c := 0;
   112.             w := w + 1;
   113.          end if;
   114.          size := size + 1;
   115.          exit word_loop when w > end_address;
   116.       end loop word_loop;
   117.       add_in_the_IO_CPU_time(the_TR, size);
   118.    exception
   119.       when end_of_stream =>
   120.          add_in_the_IO_CPU_time(the_TR, size);
   121.          correct_transfer_time(the_TR, size);
   122.          the_TR.is_abnormal := True;
   123.          diagnose(the_TR.stream, "premature EOF in read_orders");
   124.    end read_orders;
   125.
   126.    -- Like read_orders, but transfer to End_Message.
   127.    procedure read_orders_to_EM (the_TR    : in out TR.device;
   128.                                 Q_operand : in KDF9.Q_register) is
   129.       start_address : constant KDF9.address := Q_operand.I;
   130.       end_address   : constant KDF9.address := Q_operand.M;
   131.       size   : KDF9.word := 0;
   132.       w      : KDF9.address := start_address;
   133.       c      : KDF9.symbol_number := 0;
   134.       char   : Character;
   135.       octet  : KDF9.syllable;
   136.       symbol : KDF9.symbol;
   137.    begin
   138.       validate_range_access(start_address, end_address);
   139.    word_loop:
   140.       loop
   141.          loop
   142.             get_byte(char, the_TR.stream);
   143.          exit when Character'Pos(char) /= 0 and Character'Pos(char) /= 255;
   144.          end loop;
   145.          octet  := KDF9.syllable(Character'Pos(char));
   146.          symbol := KDF9.symbol((octet and 16#6_0#)/2 or (octet and 16#F#));
   147.          store_symbol(symbol, w, c);
   148.          if c < KDF9.symbol_number'Last then
   149.             c := c + 1;
   150.          else
   151.             c := 0;
   152.             w := w + 1;
   153.          end if;
   154.          size := size + 1;
   155.       exit word_loop when w > end_address;
   156.          if symbol = KDF9.End_Message then
   157.             for d in 1 .. 7-c loop
   158.                store_symbol(KDF9.Blank_Space, w, c+d);
   159.             end loop;
   160.             exit word_loop;
   161.          end if;
   162.       end loop word_loop;
   163.       add_in_the_IO_CPU_time(the_TR, size);
   164.       correct_transfer_time(the_TR, size);
   165.    exception
   166.       when end_of_stream =>
   167.          add_in_the_IO_CPU_time(the_TR, size);
   168.          correct_transfer_time(the_TR, size);
   169.          the_TR.is_abnormal := True;
   170.          diagnose(the_TR.stream, "premature EOF in read_orders_to_EM");
   171.    end read_orders_to_EM;
   172.
   173.    -- PRQq
   174.    overriding
   175.    procedure PIA (the_TR      : in out TR.device;
   176.                   Q_operand   : in KDF9.Q_register;
   177.                   set_offline : in Boolean) is
   178.    begin
   179.       initialize_byte_mode_transfer(the_TR, Q_operand, set_offline);
   180.       if the_execution_mode = boot_mode then
   181.          read_orders(the_TR, Q_operand);
   182.       else
   183.          read(the_TR, Q_operand);
   184.       end if;
   185.       set_lockouts(Q_operand);
   186.    end PIA;
   187.
   188.    -- PREQq
   189.    overriding
   190.    procedure PIB (the_TR      : in out TR.device;
   191.                   Q_operand   : in KDF9.Q_register;
   192.                   set_offline : in Boolean) is
   193.    begin
   194.       initialize_byte_mode_transfer(the_TR, Q_operand, set_offline);
   195.       if the_execution_mode = boot_mode then
   196.          read_orders_to_EM(the_TR, Q_operand);
   197.       else
   198.          read_to_EM(the_TR, Q_operand);
   199.       end if;
   200.       set_lockouts(Q_operand);
   201.    end PIB;
   202.
   203.    -- PRCQq
   204.    overriding
   205.    procedure PIC (the_TR      : in out TR.device;
   206.                   Q_operand   : in KDF9.Q_register;
   207.                   set_offline : in Boolean) is
   208.    begin
   209.       initialize_byte_mode_transfer(the_TR, Q_operand, set_offline);
   210.       words_read(the_TR, Q_operand);
   211.       set_lockouts(Q_operand);
   212.    end PIC;
   213.
   214.    -- PRCEQq
   215.    overriding
   216.    procedure PID (the_TR      : in out TR.device;
   217.                   Q_operand   : in KDF9.Q_register;
   218.                   set_offline : in Boolean) is
   219.    begin
   220.       initialize_byte_mode_transfer(the_TR, Q_operand, set_offline);
   221.       words_read_to_EM(the_TR, Q_operand);
   222.       set_lockouts(Q_operand);
   223.    end PID;
   224.
   225.    -- as PIA
   226.    overriding
   227.    procedure PIE (the_TR      : in out TR.device;
   228.                   Q_operand   : in KDF9.Q_register;
   229.                   set_offline : in Boolean) is
   230.    begin
   231.       PIA(the_TR, Q_operand, set_offline);
   232.    end PIE;
   233.
   234.    -- as PIB
   235.    overriding
   236.    procedure PIF (the_TR      : in out TR.device;
   237.                   Q_operand   : in KDF9.Q_register;
   238.                   set_offline : in Boolean) is
   239.    begin
   240.       PIB(the_TR, Q_operand, set_offline);
   241.    end PIF;
   242.
   243.    -- as PIC
   244.    overriding
   245.    procedure PIG (the_TR      : in out TR.device;
   246.                   Q_operand   : in KDF9.Q_register;
   247.                   set_offline : in Boolean) is
   248.    begin
   249.       PIC(the_TR, Q_operand, set_offline);
   250.    end PIG;
   251.
   252.    -- as PID
   253.    overriding
   254.    procedure PIH (the_TR      : in out TR.device;
   255.                   Q_operand   : in KDF9.Q_register;
   256.                   set_offline : in Boolean) is
   257.    begin
   258.       PID(the_TR, Q_operand, set_offline);
   259.    end PIH;
   260.
   261.    -- the_T_bit := (the reader is set to 8-track mode);
   262.    --    it is always in 8-track mode, as 5-track input is not supported.
   263.    overriding
   264.    procedure PMB (the_TR      : in out TR.device;
   265.                   Q_operand   : in KDF9.Q_register;
   266.                   set_offline : in Boolean) is
   267.       pragma Unreferenced(set_offline);
   268.    begin
   269.       validate_device(the_TR, Q_operand);
   270.       validate_parity(the_TR);
   271.       the_T_bit := 1;
   272.       take_note_of(Q_operand, the_TR.device_name, the_T_bit);
   273.    end PMB;
   274.
   275.    TR_quantum : constant := 1E6 / 1_000;  -- 1000 characters per second.
   276.
   277.    --
   278.    -- TR0 is the hardware bootstrap device for reading initial orders.
   279.    --
   280.
   281.    TR0 : aliased TR.device (TR0_number,
   282.                             kind    => TR_kind,
   283.                             unit    => 0,
   284.                             quantum => TR_quantum,
   285.                             is_slow => True);
   286.
   287.    TR1 : aliased TR.device (TR1_number,
   288.                             kind    => TR_kind,
   289.                             unit    => 1,
   290.                             quantum => TR_quantum,
   291.                             is_slow => True);
   292.    pragma Unreferenced(TR1);
   293.
   294.    procedure load_a_program is
   295.       store_limit : constant := 32767 * 2**24;
   296.       descriptor  : constant KDF9.Q_register := (C => TR0.number, I => 0, M => 8191);
   297.    begin
   298.       if is_unallocated(buffer(TR0_number)) then
   299.          set_state_of(buffer(TR0_number), allocated => True);
   300.       end if;
   301.       initialize_byte_mode_transfer(TR0, descriptor, set_offline => False);
   302.       read_bytes_verbatim(TR0, descriptor);
   303.       complete_all_extant_transfers;  -- To get an accurate elapsed time.
   304.       save_the_initial_jump;
   305.        -- Set the store limit in E1L.
   306.       store_halfword(store_limit, 1, 1);
   307.       store_word(todays_date_28n_years_ago, 7);
   308.       -- Set the time iff we are not computing a signature, to get a repeatable hash.
   309.       if not the_signature_is_enabled then
   310.          KDF9.Directors.set_the_time_of_loading(the_time_of_day);
   311.       end if;
   312.       set_state_of(buffer(TR0_number), allocated => False);
   313.       reattach_TR0("TR0");
   314.       clear_IOC_FIFO;
   315.    end load_a_program;
   316.
   317.    procedure bootstrap_the_KDF9 is
   318.       descriptor  : constant KDF9.Q_register := (C => TR0.number, I => 0, M => 8);
   319.    begin
   320.       read_orders(TR0, descriptor);
   321.       clear_IOC_FIFO;
   322.    end bootstrap_the_KDF9;
   323.
   324.    overriding
   325.    procedure reattach (the_buffer  : in out TR.device;
   326.                        to_the_file : in String) is
   327.    begin
   328.       IOC.byte_device(the_buffer).reattach(to_the_file);
   329.       the_buffer.current_case := KDF9.Case_Normal;
   330.    end reattach;
   331.
   332.    procedure reattach_TR0 (to_the_file : in String) is
   333.    begin
   334.       reattach(TR0, to_the_file);
   335.    end reattach_TR0;
   336.
   337. end IOC.two_shift.TR;

Compiling: ../Source\ioc-two_shift-tr.ads
Source file time stamp: 2015-06-18 00:56:18
Compiled at: 2015-10-28 18:13:41

     1. -- ioc-two_shift-tr.ads
     2. --
     3. -- Emulation of a paper tape reader buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package IOC.two_shift.TR is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    type device is new IOC.two_shift.device with private;
    24.
    25.    -- PRQq
    26.    overriding
    27.    procedure PIA (the_TR      : in out TR.device;
    28.                   Q_operand   : in KDF9.Q_register;
    29.                   set_offline : in Boolean);
    30.    -- PREQq
    31.    overriding
    32.    procedure PIB (the_TR      : in out TR.device;
    33.                   Q_operand   : in KDF9.Q_register;
    34.                   set_offline : in Boolean);
    35.    --PRCQq
    36.    overriding
    37.    procedure PIC (the_TR      : in out TR.device;
    38.                   Q_operand   : in KDF9.Q_register;
    39.                   set_offline : in Boolean);
    40.    -- PRCEQq
    41.    overriding
    42.    procedure PID (the_TR      : in out TR.device;
    43.                   Q_operand   : in KDF9.Q_register;
    44.                   set_offline : in Boolean);
    45.    -- as PIA
    46.    overriding
    47.    procedure PIE (the_TR      : in out TR.device;
    48.                   Q_operand   : in KDF9.Q_register;
    49.                   set_offline : in Boolean);
    50.    -- as PIB
    51.    overriding
    52.    procedure PIF (the_TR      : in out TR.device;
    53.                   Q_operand   : in KDF9.Q_register;
    54.                   set_offline : in Boolean);
    55.    -- as PIC
    56.    overriding
    57.    procedure PIG (the_TR      : in out TR.device;
    58.                   Q_operand   : in KDF9.Q_register;
    59.                   set_offline : in Boolean);
    60.    -- as PID
    61.    overriding
    62.    procedure PIH (the_TR      : in out TR.device;
    63.                   Q_operand   : in KDF9.Q_register;
    64.                   set_offline : in Boolean);
    65.
    66.    -- TR := (the reader is set to 8-track mode)
    67.    overriding
    68.    procedure PMB (the_TR      : in out TR.device;
    69.                   Q_operand   : in KDF9.Q_register;
    70.                   set_offline : in Boolean);
    71.
    72.    -- Reattach the reader to another file and set CASE NORMAL.
    73.    overriding
    74.    procedure reattach (the_buffer  : in out TR.device;
    75.                        to_the_file : in String);
    76.
    77.    -- Reattach TR0 to the specified binary program file.
    78.    procedure reattach_TR0 (to_the_file : in String);
    79.
    80.    procedure bootstrap_the_KDF9;
    81.
    82.    procedure load_a_program;
    83.
    84. private
    85.
    86.    type device is new IOC.two_shift.device with null record;
    87.
    88.    overriding
    89.    procedure Initialize (the_TR : in out TR.device);
    90.
    91.    overriding
    92.    procedure Finalize (the_TR : in out TR.device);
    93.
    94. end IOC.two_shift.TR;

 337 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\kdf9.adb
Source file time stamp: 2015-06-18 00:56:02
Compiled at: 2015-10-28 18:13:43

     1. -- kdf9.adb
     2. --
     3. -- The machine-state manipulations used by the CPU microcode.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Unchecked_Conversion;
    20. --
    21. with disassembly;
    22. with exceptions;
    23. with KDF9.compressed_opcodes;
    24. with KDF9.CPU;
    25. with KDF9.PHU_store;
    26. with KDF9.store;
    27. with settings;
    28. with tracing;
    29.
    30. use  disassembly;
    31. use  exceptions;
    32. use  KDF9.compressed_opcodes;
    33. use  KDF9.CPU;
    34. use  KDF9.PHU_store;
    35. use  KDF9.store;
    36. use  settings;
    37. use  tracing;
    38.
    39. package body KDF9 is
    40.
    41.    C_part_scale : constant KDF9.word := 2**32;
    42.    I_part_scale : constant KDF9.word := 2**16;
    43.
    44.    function as_Q (the_word : KDF9.word)
    45.    return KDF9.Q_register is
    46.    begin
    47.       return (
    48.               C => KDF9.Q_part(KDF9.word'(the_word / C_part_scale)),
    49.               I => KDF9.Q_part(KDF9.word'(the_word / I_part_scale) and Q_part_mask),
    50.               M => KDF9.Q_part(the_word and Q_part_mask)
    51.              );
    52.    end as_Q;
    53.
    54.    function as_word (the_Q : KDF9.Q_register)
    55.    return KDF9.word is
    56.    begin
    57.       return KDF9.word(the_Q.C) * C_part_scale
    58.            + KDF9.word(the_Q.I) * I_part_scale
    59.            + KDF9.word(the_Q.M);
    60.    end;
    61.
    62.    function sign_extended (Q : KDF9.Q_part)
    63.    return KDF9.word is
    64.    begin
    65.       return unsign(CPU.signed(resign(Q)));
    66.    end sign_extended;
    67.
    68.    function as_word (the_link : KDF9.code_link) return KDF9.word is
    69.       function link_Q_part is new Ada.Unchecked_Conversion(KDF9.code_link, KDF9.Q_part);
    70.    begin
    71.       return KDF9.word(link_Q_part(the_link));
    72.    end as_word;
    73.
    74.    function as_link (the_word : KDF9.word) return KDF9.code_link is
    75.       function Q_part_link is new Ada.Unchecked_Conversion(KDF9.Q_part, KDF9.code_link);
    76.    begin
    77.       return Q_part_link(KDF9.Q_part(the_word and Q_part_mask));
    78.    end as_link;
    79.
    80.    procedure deal_with_empty_sjns is
    81.    begin
    82.       raise NOUV_trap with "SJNS empty";
    83.    end deal_with_empty_sjns;
    84.
    85.    procedure deal_with_full_sjns is
    86.    begin
    87.       raise NOUV_trap with "SJNS full";
    88.    end deal_with_full_sjns;
    89.
    90.    procedure ensure_that_the_sjns_is_not_empty is
    91.    begin
    92.       if the_sjns_depth > 0 or else the_CPU_state = Director_state then return; end if;
    93.       deal_with_empty_sjns;
    94.    end ensure_that_the_sjns_is_not_empty;
    95.
    96.    procedure ensure_that_the_sjns_is_not_full is
    97.    begin
    98.       if the_sjns_depth < 16 or else the_CPU_state = Director_state then return; end if;
    99.       deal_with_full_sjns;
   100.    end ensure_that_the_sjns_is_not_full;
   101.
   102.    procedure push (the_link : in KDF9.code_point) is
   103.       pragma Assert(the_sjns_depth < 16 or else the_CPU_state = Director_state);
   104.    begin
   105.       the_sjns(the_sjns_depth) := KDF9.code_link(the_link);
   106.       the_sjns_depth := the_sjns_depth + 1;
   107.    end push;
   108.
   109.    function pop
   110.    return KDF9.code_point is
   111.       pragma Assert(the_sjns_depth > 0 or else the_CPU_state = Director_state);
   112.    begin
   113.       the_sjns_depth := the_sjns_depth - 1;
   114.       return KDF9.code_point(the_sjns(the_sjns_depth));
   115.    end pop;
   116.
   117.    function sjns_top
   118.    return KDF9.code_link is
   119.       pragma Assert(the_sjns_depth > 0 or else the_CPU_state = Director_state);
   120.    begin
   121.       return the_sjns(the_sjns_depth-1);
   122.    end sjns_top;
   123.
   124.    procedure deal_with_empty_nest is
   125.    begin
   126.       raise NOUV_trap with "NEST too empty";
   127.    end deal_with_empty_nest;
   128.
   129.    procedure deal_with_full_nest is
   130.    begin
   131.       raise NOUV_trap with "NEST too full";
   132.    end deal_with_full_nest;
   133.
   134.    procedure check_whether_the_nest_holds_an_operand is
   135.    begin
   136.       if the_nest_depth > 0                  or else
   137.             the_authenticity_mode = lax_mode or else
   138.                the_CPU_state = Director_state   then
   139.          return;
   140.       end if;
   141.       deal_with_empty_nest;
   142.    end check_whether_the_nest_holds_an_operand;
   143.
   144.    procedure check_whether_the_nest_holds_2_operands is
   145.    begin
   146.       if the_nest_depth > 1                  or else
   147.             the_authenticity_mode = lax_mode or else
   148.                the_CPU_state = Director_state   then
   149.          return;
   150.       end if;
   151.       deal_with_empty_nest;
   152.    end check_whether_the_nest_holds_2_operands;
   153.
   154.    procedure check_whether_the_nest_holds (at_least : in KDF9.nest_depth) is
   155.    begin
   156.       if the_nest_depth >= at_least          or else
   157.             the_authenticity_mode = lax_mode or else
   158.                the_CPU_state = Director_state   then
   159.          return;
   160.       end if;
   161.       deal_with_empty_nest;
   162.    end check_whether_the_nest_holds;
   163.
   164.    procedure ensure_that_the_nest_holds_an_operand is
   165.    begin
   166.       if the_nest_depth > 0                or else
   167.             the_CPU_state = Director_state    then
   168.          return;
   169.       end if;
   170.       deal_with_empty_nest;
   171.    end ensure_that_the_nest_holds_an_operand;
   172.
   173.    procedure ensure_that_the_nest_holds_2_operands is
   174.    begin
   175.       if the_nest_depth > 1                or else
   176.             the_CPU_state = Director_state    then
   177.          return;
   178.       end if;
   179.       deal_with_empty_nest;
   180.    end ensure_that_the_nest_holds_2_operands;
   181.
   182.    procedure ensure_that_the_nest_holds (at_least : in KDF9.nest_depth) is
   183.    begin
   184.       if the_nest_depth >= at_least        or else
   185.             the_CPU_state = Director_state    then
   186.          return;
   187.       end if;
   188.       deal_with_empty_nest;
   189.    end ensure_that_the_nest_holds;
   190.
   191.    procedure ensure_that_the_nest_has_room_for_a_result is
   192.    begin
   193.       if the_nest_depth < 16               or else
   194.             the_CPU_state = Director_state    then
   195.          return;
   196.       end if;
   197.       deal_with_full_nest;
   198.    end ensure_that_the_nest_has_room_for_a_result;
   199.
   200.    procedure ensure_that_the_nest_has_room_for_2_results is
   201.    begin
   202.       if the_nest_depth < 15               or else
   203.             the_CPU_state = Director_state    then
   204.          return;
   205.       end if;
   206.       deal_with_full_nest;
   207.    end ensure_that_the_nest_has_room_for_2_results;
   208.
   209.    procedure ensure_that_the_nest_has_room_for (at_least : in KDF9.nest_depth) is
   210.    begin
   211.       if 16-the_nest_depth >= at_least     or else
   212.             the_CPU_state = Director_state    then
   213.          return;
   214.       end if;
   215.       deal_with_full_nest;
   216.    end ensure_that_the_nest_has_room_for;
   217.
   218.    procedure push (the_word : in KDF9.word) is
   219.       pragma Assert(16-the_nest_depth > 0 or the_CPU_state = Director_state);
   220.    begin
   221.       the_nest(the_nest_depth) := the_word;
   222.       the_nest_depth := the_nest_depth + 1;
   223.    end push;
   224.
   225.    function pop
   226.    return KDF9.word is
   227.       pragma Assert(the_nest_depth > 0               or
   228.                     the_authenticity_mode = lax_mode or
   229.                     the_CPU_state = Director_state);
   230.    begin
   231.       return result : constant KDF9.word := the_nest(the_nest_depth - 1) do
   232.          the_nest(the_nest_depth - 1) := 0;
   233.          the_nest_depth := the_nest_depth - 1;
   234.       end return;
   235.    end pop;
   236.
   237.    procedure pop is
   238.       pragma Assert(the_nest_depth > 0               or
   239.                     the_authenticity_mode = lax_mode or
   240.                     the_CPU_state = Director_state);
   241.    begin
   242.       the_nest(the_nest_depth - 1) := 0;
   243.       the_nest_depth := the_nest_depth - 1;
   244.    end pop;
   245.
   246.    function read_top
   247.    return KDF9.word is
   248.       pragma Assert(the_nest_depth > 0               or
   249.                     the_authenticity_mode = lax_mode or
   250.                     the_CPU_state = Director_state);
   251.    begin
   252.       return the_nest(the_nest_depth-1);
   253.    end read_top;
   254.
   255.    procedure write_top (the_word : in KDF9.word) is
   256.       pragma Assert(the_nest_depth > 0               or
   257.                     the_authenticity_mode = lax_mode or
   258.                     the_CPU_state = Director_state);
   259.    begin
   260.       the_nest(the_nest_depth-1) := the_word;
   261.    end write_top;
   262.
   263.    procedure push (the_pair : in KDF9.pair) is
   264.       pragma Assert(16-the_nest_depth > 1 or the_CPU_state = Director_state);
   265.    begin
   266.       the_nest(the_nest_depth+0) := the_pair.lsw;
   267.       the_nest(the_nest_depth+1) := the_pair.msw;
   268.       the_nest_depth := the_nest_depth + 2;
   269.    end push;
   270.
   271.    function pop
   272.    return KDF9.pair is
   273.       pragma Assert(the_nest_depth > 1               or
   274.                     the_authenticity_mode = lax_mode or
   275.                     the_CPU_state = Director_state);
   276.    begin
   277.       return result : constant KDF9.pair := (msw => the_nest(the_nest_depth-1),
   278.                                              lsw => the_nest(the_nest_depth-2)) do
   279.          the_nest(the_nest_depth-1) := 0;
   280.          the_nest(the_nest_depth-2) := 0;
   281.          the_nest_depth := the_nest_depth - 2;
   282.       end return;
   283.    end pop;
   284.
   285.    function read_top
   286.    return KDF9.pair is
   287.       pragma Assert(the_nest_depth > 1               or
   288.                     the_authenticity_mode = lax_mode or
   289.                     the_CPU_state = Director_state);
   290.    begin
   291.       return (msw => the_nest(the_nest_depth-1),
   292.               lsw => the_nest(the_nest_depth-2));
   293.    end read_top;
   294.
   295.    procedure write_top (the_pair : in KDF9.pair) is
   296.       pragma Assert(the_nest_depth > 1               or
   297.                     the_authenticity_mode = lax_mode or
   298.                     the_CPU_state = Director_state);
   299.    begin
   300.       the_nest(the_nest_depth-1) := the_pair.msw;
   301.       the_nest(the_nest_depth-2) := the_pair.lsw;
   302.    end write_top;
   303.
   304.
   305. --
   306.    -- Support for Director-only operations.
   307. --
   308.
   309.    -- Set BA (bits D38:47), CPL (D34:35) and NOL (D24:33).
   310.    procedure set_K1_register (setting : in KDF9.word) is
   311.    begin
   312.       BA  := KDF9.address(setting mod 2**10) * 2**5;
   313.       CPL := KDF9.priority((setting / 2**12) and 2#11#);
   314.       NOL := KDF9.address((setting / 2**14) mod 2**10) * 2**5 + 31;
   315.    end set_K1_register;
   316.
   317.    -- Set CPDAR (bits D32:47).
   318.    procedure set_K2_register (setting : in KDF9.word) is
   319.       CPDAR_Q : KDF9.Q_part := KDF9.Q_part(setting mod 2**16) and KDF9.Q_part_mask;
   320.    begin
   321.       for i in KDF9.buffer_number loop
   322.          the_CPDAR(15-i) := KDF9.one_bit(CPDAR_Q mod 2);
   323.          CPDAR_Q := CPDAR_Q / 2;
   324.       end loop;
   325.    end set_K2_register;
   326.
   327.    -- Set context (bits D0:1), nest_depth (D2:6) and sjns_depth (D7:11).
   328.    procedure set_K3_register (setting : in KDF9.word) is
   329.    begin
   330.       -- Save the current register values in the register bank.
   331.       register_bank(the_context).nest := the_nest;
   332.       register_bank(the_context).sjns := the_sjns;
   333.       register_bank(the_context).Q_store := the_Q_store;
   334.       -- Set the new context.
   335.       the_context := KDF9.context(KDF9.word'(setting / 2**46));
   336.       the_nest_depth := KDF9.nest_depth(setting / 2**41 mod 2**5);
   337.       the_sjns_depth := KDF9.sjns_depth(setting / 2**36 mod 2**5);
   338.       -- Restore the register values for the new context.
   339.       the_nest := register_bank(the_context).nest;
   340.       the_sjns := register_bank(the_context).sjns;
   341.       the_Q_store := register_bank(the_context).Q_store;
   342.    end set_K3_register;
   343.
   344.    a_jiffy : constant := 1.0 / 1_048_576.0;  -- = 2 **(-20)
   345.    type seconds is delta a_jiffy range 0.0 .. 31_622_400_000.0;  -- 1000 leapyears!
   346.
   347.    -- Let the real elapsed time catch up with the_real_time virtual seconds.
   348.    procedure delay_until (the_real_time : in KDF9.microseconds) is
   349.       quantum : constant seconds := seconds(2**10) * a_jiffy;  -- ~= TR character time
   350.       the_lag : seconds;
   351.    begin
   352.       the_lag := seconds(the_real_time - the_last_delay_time) * a_jiffy;
   353.       if the_lag >= quantum then  -- More than a quantum of virtual elapsed time has passed.
   354.          delay Duration(the_lag);
   355.          the_last_delay_time := the_real_time;
   356.       end if;
   357.       the_elapsed_time := the_real_time;
   358.    end delay_until;
   359.
   360.    procedure delay_by (the_delay_time : in KDF9.microseconds) is
   361.    begin
   362.       if authentic_timing_is_wanted then
   363.          delay_until(the_clock_time + the_delay_time);
   364.       end if;
   365.    end delay_by;
   366.
   367.    -- Advance to the larger of the_CPU_time, the_elapsed_time, and the_last_delay_time.
   368.    -- Cap the increase to prevent a spurious double-clock (RESET) interrupt in Director.
   369.    procedure update_the_elapsed_time is
   370.       max_elapsed_time : constant KDF9.microseconds := the_last_K4_time + 2**20 - 1;
   371.    begin
   372.       the_elapsed_time := KDF9.microseconds'Max(the_elapsed_time, the_last_delay_time);
   373.       the_elapsed_time := KDF9.microseconds'Max(the_elapsed_time, the_CPU_time);
   374.       if the_execution_mode = boot_mode and the_CPU_state = Director_state then
   375.          the_elapsed_time := KDF9.microseconds'Min(the_elapsed_time, max_elapsed_time);
   376.       end if;
   377.    end update_the_elapsed_time;
   378.
   379.    -- The virtual elapsed time.
   380.    function the_clock_time
   381.    return KDF9.microseconds is
   382.    begin
   383.       update_the_elapsed_time;
   384.       return the_elapsed_time;
   385.    end the_clock_time;
   386.
   387.    procedure advance_the_clock_past (this_time : in KDF9.microseconds) is
   388.    begin
   389.       the_elapsed_time := KDF9.microseconds'Max(the_elapsed_time, this_time);
   390.       update_the_elapsed_time;
   391.       if authentic_timing_is_wanted then
   392.          delay_until(the_elapsed_time);
   393.       end if;
   394.    end advance_the_clock_past;
   395.
   396.    procedure synchronize_the_real_and_virtual_times is
   397.    begin
   398.       update_the_elapsed_time;
   399.       if authentic_timing_is_wanted then
   400.          delay_until(the_elapsed_time);
   401.       end if;
   402.    end synchronize_the_real_and_virtual_times;
   403.
   404.    -- Get clock (bits D0:15) and RFIR (D16:31).
   405.    function get_K4_operand
   406.    return KDF9.word is
   407.
   408.       function RFIR_in_a_word return KDF9.word is
   409.          result : KDF9.word := 0;
   410.       begin
   411.          for r in the_RFIR'Range loop
   412.             result := result*2;
   413.             if the_RFIR(r) then
   414.                result := result or 1;
   415.             end if;
   416.          end loop;
   417.          return result;
   418.       end RFIR_in_a_word;
   419.
   420.       -- The KDF9's clock ticks once per 32 µs;
   421.       --    the emulator's virtual time has a resolution of 1µs.
   422.       time_now : constant KDF9.microseconds := the_clock_time;
   423.       interval : KDF9.microseconds := (time_now - the_last_K4_time) / 32;
   424.    begin
   425.       the_last_K4_time := time_now;
   426.       if interval >= 2**16 then
   427.          the_RFIR(RESET_flag) := True;
   428.          interval := interval mod 2**16;
   429.       end if;
   430.       return (KDF9.word(interval) * 2**16 or RFIR_in_a_word) * 2**16;
   431.    end get_K4_operand;
   432.
   433.    -- Get PHUi (bits D6i:6i+5, i = 0 .. 3).
   434.    function get_K5_operand
   435.    return KDF9.word is
   436.    begin
   437.       return K5_operand;
   438.    end get_K5_operand;
   439.
   440.    -- Get context (bits D0:1), nest_depth (D2:6) and sjns_depth (D7:11).
   441.    function get_K7_operand
   442.    return KDF9.word is
   443.    begin
   444.       return (KDF9.word(the_context)    * 2**46)
   445.           or (KDF9.word(the_nest_depth) * 2**41)
   446.           or (KDF9.word(the_sjns_depth) * 2**36);
   447.    end get_K7_operand;
   448.
   449.    procedure reset_the_internal_registers (the_new_state : in CPU_state := Director_state) is
   450.    begin
   451.       -- Set the state of a newly bootstrapped CPU.  ??
   452.       the_V_bit := 0;
   453.       the_T_bit := 0;
   454.       CIA := (0, 0);
   455.       CPL := 0;
   456.       BA  := 0;
   457.       NOL := max_address;
   458.       the_RFIR := (others => False);
   459.       ICR := 0;
   460.       the_CPU_time := 0;
   461.       the_elapsed_time := 0;
   462.       the_last_delay_time := 0;
   463.       the_last_K4_time := 0;
   464.       the_CPU_state := the_new_state;
   465.       the_CPDAR := (0 => 1, others => 0);  -- FW0 is always allocated.
   466.    end reset_the_internal_registers;
   467.
   468.    procedure reset_the_CPU_state is
   469.    begin
   470.       the_context := 0;
   471.       for set in register_bank'Range loop
   472.          register_bank(set) := (
   473.                                 nest    => (others => 0),
   474.                                 sjns    => (others => (0, 0)),
   475.                                 Q_store => (others => (0, 0, 0))
   476.                                );
   477.       end loop;
   478.       the_nest_depth := 0;
   479.       the_nest       := (others => 0);
   480.       the_sjns_depth := 0;
   481.       the_sjns       := (others => (0, 0));
   482.       the_Q_store    := (others => (0, 0, 0));
   483.       if the_execution_mode = program_mode then
   484.          reset_the_internal_registers(program_state);
   485.       else
   486.          reset_the_internal_registers(Director_state);
   487.       end if;
   488.       -- Setting NIA must follow program loading, as it fetches E0 into the IWBs.
   489.       set_NIA_to((0, 0));
   490.    end reset_the_CPU_state;
   491.
   492.    procedure reset_the_program_state is
   493.    begin
   494.       the_nest_depth := 0;
   495.       the_nest       := (others => 0);
   496.       the_sjns_depth := 0;
   497.       the_sjns       := (others => (0, 0));
   498.       the_V_bit := 0;
   499.       the_T_bit := 0;
   500.       the_CPDAR := (0 => 1, others => 0);  -- FW0 is always allocated.
   501.       -- Setting NIA must follow program loading, as it fetches E0 into the IWBs.
   502.       set_NIA_to((0, 0));
   503.    end reset_the_program_state;
   504.
   505.    procedure signal_interrupt (the_reason : in KDF9.interrupt_number) is
   506.    begin
   507.       take_note_of(the_reason,
   508.                    ICR, CIA, the_elapsed_time,
   509.                    (the_CPU_state = Director_state), CPL
   510.                   );
   511.       the_RFIR(the_reason) := True;
   512.       case the_execution_mode is
   513.          when boot_mode =>
   514.             -- Interrupts are either effected or deferred to Director.
   515.             if the_CPU_state = program_state or the_reason = RESET_flag then
   516.                -- Effect an actual interrupt into Director.
   517.                if the_reason = LOV_flag or the_reason = LIV_flag then
   518.                   push(CIA);  -- Resume after LOV at the interrupted instruction.
   519.                else
   520.                   push(NIA);  -- Restart after the interrupted instruction.
   521.                end if;
   522.                BA := 0;
   523.                the_CPU_state := Director_state;
   524.                set_NIA_to((0, 0));
   525.             else
   526.                -- Defer: Director will eventually find any request left in the_RFIR.
   527.                -- NOUV is completely suppressed in Director state.
   528.                the_RFIR(NOUV_flag) := False;
   529.             end if;
   530.          when test_program_mode =>
   531.             -- Interrupts other than LOV and RESET are ignored.
   532.             case the_reason is
   533.                when LOV_flag =>
   534.                   raise LOV_trap;
   535.                when RESET_flag =>
   536.                   raise RESET_trap;
   537.                when others =>
   538.                   null;
   539.             end case;
   540.          when program_mode =>
   541.             -- Interrupts other than LOV are treated as failures.
   542.             case the_reason is
   543.                when PR_flag =>
   544.                   raise PR_trap;
   545.                when FLEX_flag =>
   546.                   raise FLEX_trap;
   547.                when LIV_flag =>
   548.                   raise LIV_trap;
   549.                when NOUV_flag =>
   550.                   raise NOUV_trap;
   551.                when EDT_flag =>
   552.                   raise EDT_trap;
   553.                when OUT_flag =>
   554.                   raise OUT_trap;
   555.                when LOV_flag =>
   556.                   raise LOV_trap;
   557.                when RESET_flag =>
   558.                   raise RESET_trap;
   559.                when others =>
   560.                   raise emulation_failure with "invalid RFI";
   561.             end case;
   562.       end case;
   563.    end signal_interrupt;
   564.
   565.    procedure LIV_if_user_mode (the_reason : in String := "Director-only instruction") is
   566.    begin
   567.       if the_CPU_state = Director_state then
   568.          return;
   569.       end if;
   570.       if the_execution_mode = boot_mode then
   571.          signal_interrupt(LIV_flag);
   572.       else
   573.          raise LIV_trap with the_reason;
   574.       end if;
   575.    end LIV_if_user_mode;
   576.
   577.    procedure LOV_if_user_mode is
   578.    begin
   579.       -- LOV was TOTALLY suppressed in Director state.
   580.       if the_CPU_state /= Director_state then
   581.          set_NIA_to(CIA);
   582.          signal_interrupt(LOV_flag);
   583.       end if;
   584.    end LOV_if_user_mode;
   585.
   586.    procedure trap_invalid_instruction (the_message : in String := "invalid instruction") is
   587.    begin
   588.       LIV_if_user_mode(the_message);
   589.       -- We get here only in Director mode.
   590.       -- Invalid operations in Director raise a debugging exception for now.
   591.       raise Director_failure with the_message & ": " & the_name_of(INS);
   592.    end trap_invalid_instruction;
   593.
   594.    procedure change_to_user_state_at (new_IAR : in KDF9.code_point) is  -- STUB
   595.    begin
   596.       the_CPU_state := program_state;
   597.       set_NIA_to(new_IAR);
   598.    end change_to_user_state_at;
   599.
   600.    procedure increment_by_1 (the_link : in out KDF9.code_point) is
   601.    begin
   602.       if the_link.syllable_number < 5 then
   603.          the_link.syllable_number := the_link.syllable_number + 1;
   604.       else
   605.          the_link.syllable_number := 0;
   606.          the_link.word_number     := the_link.word_number + 1;
   607.       end if;
   608.    end increment_by_1;
   609.
   610.    procedure increment_by_2 (the_link : in out KDF9.code_point) is
   611.    begin
   612.       if the_link.syllable_number < 4 then
   613.          the_link.syllable_number := the_link.syllable_number + 2;
   614.       else
   615.          the_link.syllable_number := the_link.syllable_number - 4;
   616.          the_link.word_number     := the_link.word_number + 1;
   617.       end if;
   618.    end increment_by_2;
   619.
   620.    procedure increment_by_3 (the_link : in out KDF9.code_point) is
   621.    begin
   622.       if the_link.syllable_number < 3 then
   623.          the_link.syllable_number := the_link.syllable_number + 3;
   624.       else
   625.          the_link.syllable_number := the_link.syllable_number - 3;
   626.          the_link.word_number     := the_link.word_number + 1;
   627.       end if;
   628.    end increment_by_3;
   629.
   630.    -- the_syllable_cache holds two instruction words, pre-split into syllables.
   631.    -- They would have been held in IWB0 and IWB1 by Main Control in the KDF9.
   632.
   633.    subtype syllable_cache_range is Natural range 0 .. 11;
   634.
   635.    the_syllable_cache  : array (syllable_cache_range) of KDF9.syllable;
   636.    the_cache_index     : syllable_cache_range := 0;
   637.    the_cached_location : KDF9.code_location   := 0;
   638.
   639.    -- The amount by which the_CPU_time is increased, for a refill of the_syllable_cache.
   640.    the_instruction_fetch_time : constant := 8;  -- microseconds
   641.
   642.    function NIA return KDF9.code_point is
   643.    begin
   644.       if the_cache_index > 5 then
   645.          return (KDF9.syllable_code(the_cache_index-6), the_cached_location);
   646.       else
   647.          return (KDF9.syllable_code(the_cache_index), the_cached_location-1);
   648.       end if;
   649.    end NIA;
   650.
   651.    function NIA_word_number return KDF9.code_location is
   652.    begin
   653.       if the_cache_index > 5 then
   654.          return the_cached_location;
   655.       else
   656.          return the_cached_location - 1;
   657.       end if;
   658.    end NIA_word_number;
   659.
   660.    procedure set_NIA_to (new_NIA : in KDF9.code_point) is
   661.       mask  : constant := 8#377#;
   662.       shift : constant := 8#400#;
   663.       IWB0  : KDF9.word := fetch_word(KDF9.address(new_NIA.word_number) + 0);
   664.       IWB1  : KDF9.word := fetch_word(KDF9.address(new_NIA.word_number) + 1);
   665.    begin
   666.       if new_NIA.syllable_number > 5 then
   667.          raise RESET_trap with "syllable number > 5";
   668.       end if;
   669.
   670.       the_cache_index := syllable_cache_range(new_NIA.syllable_number);
   671.       the_cached_location := new_NIA.word_number + 1;
   672.
   673.       the_syllable_cache(5+0) := KDF9.syllable(IWB0 and mask);
   674.       IWB0 := IWB0 / shift;
   675.       the_syllable_cache(4+0) := KDF9.syllable(IWB0 and mask);
   676.       IWB0 := IWB0 / shift;
   677.       the_syllable_cache(3+0) := KDF9.syllable(IWB0 and mask);
   678.       IWB0 := IWB0 / shift;
   679.       the_syllable_cache(2+0) := KDF9.syllable(IWB0 and mask);
   680.       IWB0 := IWB0 / shift;
   681.       the_syllable_cache(1+0) := KDF9.syllable(IWB0 and mask);
   682.       IWB0 := IWB0 / shift;
   683.       the_syllable_cache(0+0) := KDF9.syllable(IWB0);
   684.
   685.       the_syllable_cache(5+6) := KDF9.syllable(IWB1 and mask);
   686.       IWB1 := IWB1 / shift;
   687.       the_syllable_cache(4+6) := KDF9.syllable(IWB1 and mask);
   688.       IWB1 := IWB1 / shift;
   689.       the_syllable_cache(3+6) := KDF9.syllable(IWB1 and mask);
   690.       IWB1 := IWB1 / shift;
   691.       the_syllable_cache(2+6) := KDF9.syllable(IWB1 and mask);
   692.       IWB1 := IWB1 / shift;
   693.       the_syllable_cache(1+6) := KDF9.syllable(IWB1 and mask);
   694.       IWB1 := IWB1 / shift;
   695.       the_syllable_cache(0+6) := KDF9.syllable(IWB1);
   696.    end set_NIA_to;
   697.
   698.    procedure set_NIA_to_the_INS_target_address is
   699.    begin
   700.       set_NIA_to(INS.target);
   701.    end set_NIA_to_the_INS_target_address;
   702.
   703.    procedure set_IWB0_and_IWB1_for_a_JCqNZS_loop is
   704.    begin
   705.       if CIA.syllable_number = 5 then
   706.          -- KDF9 did not actually detect this error, and the JCqNZS instruction often worked,
   707.          --    unless broken-into by an interrupt, which returned to the word following that
   708.          --       containing the first syllable of the JCqNZS instruction.
   709.          -- I see no case for reproducing this behaviour.
   710.          trap_invalid_instruction ("JCqNZS instruction at syllable 5");
   711.       end if;
   712.       set_NIA_to((word_number => CIA.word_number-1, syllable_number => 0));
   713.       fetching_normally := False;
   714.    end set_IWB0_and_IWB1_for_a_JCqNZS_loop;
   715.
   716.    procedure go_back_to_the_start_of_IWB0 is
   717.    begin
   718.       the_cache_index := 0;
   719.    end go_back_to_the_start_of_IWB0;
   720.
   721.    procedure continue_after_JCqNZS is
   722.    begin
   723.       if CIA.syllable_number = 4 and the_cached_location = CIA.word_number then
   724.          set_NIA_to((word_number => CIA.word_number+1, syllable_number => 0));
   725.          -- Part-overlapped order-word fetch: can happen only once per instruction,
   726.          --    and only before the instruction is executed, so no need to ADD to the_CPU_delta.
   727.          -- The formula implements a small pseudo-random variation.
   728.          the_CPU_delta := the_instruction_fetch_time - (the_elapsed_time and 2) / 2;
   729.       end if;
   730.       fetching_normally := True;
   731.    end continue_after_JCqNZS;
   732.
   733.    function next_order_syllable
   734.    return KDF9.syllable;
   735.    pragma Inline(next_order_syllable);
   736.
   737.    function next_order_syllable
   738.    return KDF9.syllable is
   739.       the_next_syllable : KDF9.syllable;
   740.    begin
   741.       the_next_syllable := the_syllable_cache(the_cache_index);
   742.       if the_cache_index < 11 then
   743.          the_cache_index := the_cache_index + 1;
   744.       elsif fetching_normally then
   745.          set_NIA_to((word_number => CIA.word_number+1, syllable_number => 0));
   746.          -- Part-overlapped order-word fetch: can happen only once per instruction,
   747.          --    and only before the instruction is executed, so no need to add to the_CPU_delta.
   748.          -- The formula implements a small pseudo-random variation.
   749.          the_CPU_delta := the_instruction_fetch_time - (the_elapsed_time and 2) / 2;
   750.       else
   751.          go_back_to_the_start_of_IWB0;
   752.       end if;
   753.       return the_next_syllable;
   754.    end next_order_syllable;
   755.
   756.    procedure decode_syllable_0 (decoded : in out KDF9.decoded_order);
   757.    pragma Inline(decode_syllable_0);
   758.
   759.    procedure decode_syllable_1 (decoded : in out KDF9.decoded_order);
   760.    pragma Inline(decode_syllable_1);
   761.
   762.    procedure decode_a_jump_order (decoded : in out KDF9.decoded_order);
   763.    pragma Inline(decode_a_jump_order);
   764.
   765.    procedure decode_a_store_access_order (decoded : in out KDF9.decoded_order);
   766.    pragma Inline(decode_a_store_access_order);
   767.
   768.    procedure decode_a_set_literal_order (decoded : in out KDF9.decoded_order);
   769.    pragma Inline(decode_a_set_literal_order);
   770.
   771.    procedure decode_syllable_0 (decoded : in out KDF9.decoded_order) is
   772.    begin
   773.       decoded.syndrome := decoded.order.syllable_0 and 8#77#;
   774.       decoded.kind := KDF9.INS_kind(decoded.order.syllable_0 / 2**6);
   775.    end decode_syllable_0;
   776.
   777.    procedure process_syllable_0_of_INS is
   778.    begin
   779.       if the_cache_index > 5 then
   780.          CIA.word_number := the_cached_location;
   781.          CIA.syllable_number := KDF9.syllable_code(the_cache_index-6);
   782.       else
   783.          CIA.word_number := the_cached_location - 1;
   784.          CIA.syllable_number := KDF9.syllable_code(the_cache_index);
   785.       end if;
   786.       INS.order.syllable_0 := next_order_syllable;
   787.       INS.syndrome := INS.order.syllable_0 and 8#77#;
   788.       INS.kind := KDF9.INS_kind(INS.order.syllable_0 / 2**6);
   789.    end process_syllable_0_of_INS;
   790.
   791.    procedure decode_syllable_1 (decoded : in out KDF9.decoded_order) is
   792.    begin
   793.       decoded.Qq := KDF9.Q_number(decoded.order.syllable_1 / 2**4);
   794.       decoded.Qk := KDF9.Q_number(decoded.order.syllable_1 and 8#17#);
   795.    end decode_syllable_1;
   796.
   797.    procedure process_syllable_1_of_INS is
   798.    begin
   799.       INS.order.syllable_1 := next_order_syllable;
   800.       INS.Qq := KDF9.Q_number(INS.order.syllable_1 / 2**4);
   801.       INS.Qk := KDF9.Q_number(INS.order.syllable_1 and 8#17#);
   802.    end process_syllable_1_of_INS;
   803.
   804.    syllable_nr_mask : constant := 2#111#;
   805.    D4_mask          : constant := 2#1000#;
   806.    D2_mask          : constant := 2#00_100_000#;
   807.    D0_thru_3_mask   : constant := 2#11_110_000#;
   808.
   809.    procedure decode_a_jump_order (decoded : in out KDF9.decoded_order) is
   810.    begin
   811.       decoded.target.syllable_number := KDF9.syllable_code(decoded.order.syllable_0 and syllable_nr_mask);
   812.       decoded.target.word_number := KDF9.code_location(decoded.order.syllable_2)
   813.                            + KDF9.code_location(decoded.Qk) * 2**8
   814.                            + KDF9.code_location(decoded.order.syllable_0 and D4_mask) * 2**9;
   815.       if (decoded.syndrome and D2_mask) /= 0 then -- not JrCq ...
   816.          decoded.syndrome := decoded.syndrome and D0_thru_3_mask;
   817.       else
   818.          decoded.syndrome := (decoded.syndrome and D0_thru_3_mask) or KDF9.syllable(decoded.Qq);
   819.       end if;
   820.       if decoded.syndrome = EXIT_9 then
   821.          -- The syllable part of EXIT is actually a halfword offset,
   822.          --    so convert it to an actual syllable number.
   823.          if decoded.target.syllable_number = 2 then
   824.             decoded.target.syllable_number := 0;
   825.          else
   826.             decoded.target.syllable_number := 3;
   827.          end if;
   828.       end if;
   829.    end decode_a_jump_order;
   830.
   831.    procedure process_syllables_1_and_2_of_a_jump_order is
   832.    begin
   833.       process_syllable_1_of_INS;
   834.       INS.order.syllable_2 := next_order_syllable;
   835.       decode_a_jump_order(INS);
   836.    end process_syllables_1_and_2_of_a_jump_order;
   837.
   838.    D5_thru_7_mask : constant := 2#111#;
   839.    D2_thru_4_mask : constant := 2#111000#;
   840.
   841.    procedure decode_a_store_access_order (decoded : in out KDF9.decoded_order) is
   842.    begin
   843.       decoded.operand := KDF9.Q_part(decoded.order.syllable_2) + KDF9.Q_part(decoded.Qk)*2**8
   844.                        + KDF9.Q_part((decoded.order.syllable_0 and D2_thru_4_mask)) * 2**9;
   845.       decoded.syndrome := decoded.syndrome and D5_thru_7_mask;
   846.    end decode_a_store_access_order;
   847.
   848.    procedure decode_a_set_literal_order (decoded : in out KDF9.decoded_order) is
   849.    begin
   850.       decoded.operand := KDF9.Q_part(decoded.order.syllable_2)
   851.                        + KDF9.Q_part(decoded.order.syllable_1)*2**8;
   852.       decoded.syndrome := 2#100#;
   853.    end decode_a_set_literal_order;
   854.
   855.    procedure process_syllables_1_and_2_of_a_data_access_order is
   856.    begin
   857.       if (INS.syndrome and D5_thru_7_mask) < 2#100# then
   858.          process_syllable_1_of_INS;
   859.          INS.order.syllable_2 := next_order_syllable;
   860.          decode_a_store_access_order(INS);
   861.       else  -- SET n and some invalid opcodes (to be discarded later)
   862.          INS.order.syllable_1 := next_order_syllable;
   863.          INS.order.syllable_2 := next_order_syllable;
   864.          decode_a_set_literal_order(INS);
   865.       end if;
   866.    end process_syllables_1_and_2_of_a_data_access_order;
   867.
   868.    procedure decode_the_next_order is
   869.    begin
   870.       -- The CPU time is adjusted by a fudge factor to account for
   871.       --    the instruction-fetch time being partly overlapped.
   872.       process_syllable_0_of_INS;
   873.       case INS.kind is
   874.          when one_syllable_order =>
   875.             return;
   876.          when two_syllable_order =>
   877.             process_syllable_1_of_INS;
   878.          when normal_jump_order =>
   879.             process_syllables_1_and_2_of_a_jump_order;
   880.          when data_access_order =>
   881.             process_syllables_1_and_2_of_a_data_access_order;
   882.       end case;
   883.    end decode_the_next_order;
   884.
   885.    procedure decode (the_order : in out KDF9.decoded_order) is
   886.    begin
   887.       decode_syllable_0(the_order);
   888.       case the_order.kind is
   889.          when one_syllable_order =>
   890.             null;
   891.          when two_syllable_order =>
   892.             decode_syllable_1(the_order);
   893.          when normal_jump_order =>
   894.             decode_syllable_1(the_order);
   895.             decode_a_jump_order(the_order);
   896.          when data_access_order =>
   897.             if (the_order.syndrome and D5_thru_7_mask) < 2#100# then
   898.                decode_syllable_1(the_order);
   899.                decode_a_store_access_order(the_order);
   900.             else  -- SET n and some invalid opcodes (to be discarded later)
   901.                decode_a_set_literal_order(the_order);
   902.             end if;
   903.       end case;
   904.    end decode;
   905.
   906.    -- the_order_at_NIA gets three syllables starting at [NIA].  It is FOR DIAGNOSTIC USE ONLY!
   907.    -- It does NOT update the CPU time properly and MUST NOT be used inside an instruxtion cycle.
   908.    function the_order_at_NIA
   909.    return KDF9.syllable_group is
   910.       saved_NIA : constant KDF9.code_point := NIA;
   911.       result    : KDF9.syllable_group;
   912.    begin
   913.       result.syllable_0 := next_order_syllable;
   914.       result.syllable_1 := next_order_syllable;
   915.       result.syllable_2 := next_order_syllable;
   916.       set_NIA_to(saved_NIA);
   917.       return result;
   918.    end the_order_at_NIA;
   919.
   920.    -- This is the initial jump from the top halfword of E0 just after loading.
   921.    E0U : KDF9.word := 0;  -- N.B. only the upper halfword is used.
   922.
   923.    procedure save_the_initial_jump is
   924.    begin
   925.       E0U := fetch_halfword(0, 0);
   926.    end save_the_initial_jump;
   927.
   928.    procedure restore_the_initial_jump is
   929.    begin
   930.        store_halfword(E0U, 0, 0);
   931.    end restore_the_initial_jump;
   932.
   933.    function the_initial_jump_was_corrupted
   934.    return Boolean is
   935.    begin
   936.       return E0U /= fetch_halfword(0, 0);
   937.    end the_initial_jump_was_corrupted;
   938.
   939.    function is_an_invalid_order (decoded : KDF9.decoded_order)
   940.    return Boolean is
   941.    begin
   942.       return (decoded.kind = normal_jump_order and decoded.target.syllable_number > 5)
   943.          or else decoded.order.syllable_0 = 8#000#
   944.             or else decoded.order.syllable_0 = 8#006#
   945.                or else decoded.order.syllable_0 = 8#040#
   946.                   or else decoded.order.syllable_0 = 8#046#
   947.                      or else decoded.order.syllable_0 = 8#055#
   948.                         or else decoded.order.syllable_0 = 8#073#
   949.                            or else decoded.order.syllable_0 = 8#076#
   950.                               or else decoded.order.syllable_0 = 8#150#;
   951.    end is_an_invalid_order;
   952.
   953.    the_signature_hash : KDF9.word := 0;
   954.
   955.    function the_digital_signature
   956.    return KDF9.word is
   957.    begin
   958.       return the_signature_hash;
   959.    end the_digital_signature;
   960.
   961.    function visible_state_hash
   962.    return KDF9.word;
   963.    pragma Inline(visible_state_hash);
   964.
   965.    function visible_state_hash
   966.    return KDF9.word is
   967.       hash : KDF9.word;
   968.    begin
   969.       hash := rotate_word_right(the_signature_hash, 1) xor KDF9.word(ICR);
   970.       hash := rotate_word_right(hash, 1) xor as_word(the_Q_store(INS.Qq));
   971.       hash := rotate_word_right(hash, 1) xor as_word(the_Q_store(INS.Qk));
   972.       if the_sjns_depth > 0 then
   973.          for s in reverse KDF9.sjns_depth range 0 .. the_sjns_depth-1 loop
   974.                hash := rotate_word_right(hash, 1) xor as_word(the_sjns(s));
   975.          end loop;
   976.       end if;
   977.       if the_nest_depth > 0 then
   978.          for n in reverse KDF9.nest_depth range 0 .. the_nest_depth-1 loop
   979.                hash := rotate_word_right(hash, 1) xor the_nest(n);
   980.          end loop;
   981.       end if;
   982.       return hash;
   983.    end visible_state_hash;
   984.
   985.    procedure update_the_digital_signature is
   986.    begin
   987.       the_signature_hash := visible_state_hash;
   988.    end update_the_digital_signature;
   989.
   990. end KDF9;

Compiling: ../Source\kdf9.ads
Source file time stamp: 2015-06-18 00:56:00
Compiled at: 2015-10-28 18:13:43

     1. -- kdf9.ads
     2. --
     3. -- The architecturally-defined data formats of the KDF9 computer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with System;
    20. --
    21. with Latin_1;
    22.
    23. use System;
    24. --
    25. use Latin_1;
    26.
    27. package KDF9 is
    28.
    29. --
    30.    -- The following register types are available in user and Director states.
    31. --
    32.
    33.    --
    34.    -- The fundamental 48-bit storage unit is the 48-bit word.
    35.    --
    36.
    37.    --
    38.    -- The 48-bit word, considered as an unsigned integer.
    39.    --
    40.    type word is mod 2**48;
    41.
    42.    word_mask : constant := 8#7777777777777777#;
    43.    min_word  : constant := 8#4000000000000000#;
    44.    max_word  : constant := 8#3777777777777777#;
    45.
    46.    all_zero_bits : constant KDF9.word := 0;
    47.    one_in_ls_bit : constant KDF9.word := 1;
    48.    sign_bit      : constant KDF9.word := KDF9.min_word;
    49.    not_sign_bit  : constant KDF9.word := KDF9.max_word;
    50.    all_one_bits  : constant KDF9.word := KDF9.word_mask;
    51.
    52.    --
    53.    -- The 96-bit double word, considered as a pair of words.
    54.    --
    55.    type pair is
    56.       record
    57.          msw, lsw : KDF9.word;
    58.       end record;
    59.
    60.    --
    61.    -- The fundamental 16-bit storage unit.
    62.    --
    63.    type field_of_16_bits is mod 2**16;
    64.
    65.    --
    66.    -- The 16-bit word, considered as a field of a Q register.
    67.    --
    68.    type Q_part is new KDF9.field_of_16_bits;
    69.
    70.    Q_part_mask : constant := KDF9.Q_part'Last;
    71.
    72.    function sign_extended (Q : KDF9.Q_part)
    73.    return KDF9.word;
    74.    pragma Inline(sign_extended);
    75.
    76.    --
    77.    -- The 16-bit word, considered as a buffer (DMA channel) number.
    78.    --
    79.    subtype buffer_number is KDF9.Q_part range 0 .. 15;
    80.
    81.    buffer_number_mask : constant := buffer_number'Last;
    82.
    83.    --
    84.    -- The 16-bit word, considered as a core-store address.
    85.    --
    86.    subtype address is KDF9.Q_part range 0 .. 8#77777#;
    87.
    88.    --
    89.    -- The Q-store element.
    90.    --
    91.    type Q_register is
    92.       record
    93.          C, I, M : KDF9.Q_part;
    94.       end record;
    95.
    96.    function as_Q (the_word : KDF9.word)
    97.    return KDF9.Q_register;
    98.    pragma Inline(as_Q);
    99.
   100.    function as_word (the_Q : KDF9.Q_register)
   101.    return KDF9.word;
   102.    pragma Inline(as_word);
   103.
   104.    --
   105.    -- The 8-bit instruction syllable and its components.
   106.    --
   107.    type syllable is mod 2**8;
   108.
   109.    subtype syndrome is KDF9.syllable range 0 .. 63;
   110.    subtype Q_number is KDF9.syllable range 0 .. 15;
   111.
   112.    type syllable_group is
   113.       record
   114.          syllable_0, syllable_1, syllable_2 : KDF9.syllable := 0;
   115.       end record;
   116.
   117.    --
   118.    -- An instruction address.
   119.    --
   120.    -- N.B. 5 is the hardware's largest valid syllable address.
   121.    -- The values 6 and 7 are used as diagnostic flags by ee9.
   122.    type syllable_code is mod 2**3;
   123.    type code_location is mod 2**13;
   124.
   125.    type code_point is
   126.       record
   127.          syllable_number : KDF9.syllable_code;
   128.          word_number     : KDF9.code_location;
   129.       end record;
   130.
   131.    --
   132.    -- An instruction address, in the packed hardware format.
   133.    --
   134.    type code_link is new KDF9.code_point;
   135.    for code_link'Size use 16;
   136.    for code_link'Bit_Order use Low_Order_First;
   137.    for code_link use
   138.       record
   139.          syllable_number at 0 range 13 .. 15;
   140.          word_number     at 0 range  0 .. 12;
   141.       end record;
   142.
   143.    function as_word (the_link : KDF9.code_link)
   144.    return KDF9.word;
   145.
   146.    function as_link (the_word : KDF9.word)
   147.    return KDF9.code_link;
   148.
   149.    procedure increment_by_1 (the_link : in out KDF9.code_point);
   150.    pragma Inline(increment_by_1);
   151.
   152.    procedure increment_by_2 (the_link : in out KDF9.code_point);
   153.    pragma Inline(increment_by_2);
   154.
   155.    procedure increment_by_3 (the_link : in out KDF9.code_point);
   156.    pragma Inline(increment_by_3);
   157.
   158.    --
   159.    -- The KDF9 halfword. Each occupies 24 bits, packed 2 per word.
   160.    --
   161.    type halfword is mod 2**24;
   162.    halfword_mask : constant := 8#77_77_77_77#;
   163.
   164.    subtype halfword_number is KDF9.address range 0 .. 1;
   165.
   166.    --
   167.    -- The KDF9 character. Each symbol occupies six bits, packed 8 per word.
   168.    --
   169.    type symbol is mod 2**6;
   170.
   171.    Blank_Space : constant KDF9.symbol := 8#00#;
   172.    Line_Shift  : constant KDF9.symbol := 8#02#;
   173.    Page_Change : constant KDF9.symbol := 8#03#;
   174.    Tabulation  : constant KDF9.symbol := 8#04#;
   175.    Case_Shift  : constant KDF9.symbol := 8#06#;
   176.    Case_Normal : constant KDF9.symbol := 8#07#;
   177.    Semi_Colon  : constant KDF9.symbol := 8#34#;
   178.    End_Message : constant KDF9.symbol := 8#75#;
   179.    Word_Filler : constant KDF9.symbol := 8#77#;
   180.
   181.    type symbol_number is mod 8;
   182.
   183.    --
   184.    -- KDF9 <=> ISO Latin_1 character code inter-relationaships.
   185.    --
   186.
   187.    type output_code_table is array (KDF9.symbol) of Character;
   188.    type input_code_table  is array (Character)   of KDF9.symbol;
   189.
   190.    C_N : constant Character := 'ñ';  -- Models KDF9's Case_Normal in Latin_1.
   191.    C_S : constant Character := 'ß';  -- Models KDF9's Case_Shift  in Latin_1.
   192.    E_M : constant Character := '|';  -- Models KDF9's End_Message in Latin_1.
   193.    W_F : constant Character := 'Ø';  -- Models KDF9's Word Filler in Latin_1.
   194.
   195.    -- The Line Printer code:
   196.    --    W_F is used for values that have no printable representation.
   197.    to_LP : constant output_code_table
   198.          :=  (' ',  W_F,   LF,   FF,   HT,  W_F,  '%',  ''',
   199.               ':',  '=',  '(',  ')',  '£',  '*',  ',',  '/',
   200.               '0',  '1',  '2',  '3',  '4',  '5',  '6',  '7',
   201.               '8',  '9',  W_F,  'º',  ';',  '+',  '-',  '.',
   202.               W_F,  'A',  'B',  'C',  'D',  'E',  'F',  'G',
   203.               'H',  'I',  'J',  'K',  'L',  'M',  'N',  'O',
   204.               'P',  'Q',  'R',  'S',  'T',  'U',  'V',  'W',
   205.               'X',  'Y',  'Z',  W_F,  W_F,  E_M,  W_F,  W_F
   206.              );
   207.
   208.    -- The Card Reader code:
   209.    --    W_F is used for external characters that have no assigned punching.
   210.    CR_in : constant input_code_table
   211.          := (' ' => 8#00#,  '"' => 8#01#,   LF => 8#02#,   FF => 8#03#,
   212.               HT => 8#04#,  '#' => 8#05#,  '%' => 8#06#,  ''' => 8#07#,
   213.              ':' => 8#10#,  '=' => 8#11#,  '(' => 8#12#,  ')' => 8#13#,
   214.              '£' => 8#14#,  '*' => 8#15#,  ',' => 8#16#,  '/' => 8#17#,
   215.              '0' => 8#20#,  '1' => 8#21#,  '2' => 8#22#,  '3' => 8#23#,
   216.              '4' => 8#24#,  '5' => 8#25#,  '6' => 8#26#,  '7' => 8#27#,
   217.              '8' => 8#30#,  '9' => 8#31#,  '_' => 8#32#,  'º' => 8#33#,
   218.              ';' => 8#34#,  '+' => 8#35#,  '-' => 8#36#,  '.' => 8#37#,
   219.
   220.              '@' => 8#40#,  'A' => 8#41#,  'B' => 8#42#,  'C' => 8#43#,
   221.              'D' => 8#44#,  'E' => 8#45#,  'F' => 8#46#,  'G' => 8#47#,
   222.              'H' => 8#50#,  'I' => 8#51#,  'J' => 8#52#,  'K' => 8#53#,
   223.              'L' => 8#54#,  'M' => 8#55#,  'N' => 8#56#,  'O' => 8#57#,
   224.              'P' => 8#60#,  'Q' => 8#61#,  'R' => 8#62#,  'S' => 8#63#,
   225.              'T' => 8#64#,  'U' => 8#65#,  'V' => 8#66#,  'W' => 8#67#,
   226.              'X' => 8#70#,  'Y' => 8#71#,  'Z' => 8#72#,  '{' => 8#73#,
   227.              '}' => 8#74#,  E_M => 8#75#,  '\' => 8#76#,  W_F => 8#77#,
   228.
   229.                             'a' => 8#41#,  'b' => 8#42#,  'c' => 8#43#,
   230.              'd' => 8#44#,  'e' => 8#45#,  'f' => 8#46#,  'g' => 8#47#,
   231.              'h' => 8#50#,  'i' => 8#51#,  'j' => 8#52#,  'k' => 8#53#,
   232.              'l' => 8#54#,  'm' => 8#55#,  'n' => 8#56#,  'o' => 8#57#,
   233.              'p' => 8#60#,  'q' => 8#61#,  'r' => 8#62#,  's' => 8#63#,
   234.              't' => 8#64#,  'u' => 8#65#,  'v' => 8#66#,  'w' => 8#67#,
   235.              'x' => 8#70#,  'y' => 8#71#,  'z' => 8#72#,
   236.              others => Word_Filler
   237.             );
   238.
   239.    -- The Card Punch code:
   240.    to_CP : constant output_code_table
   241.          := (' ',  '"',   LF,   FF,   HT,  '#',  '%',  ''',
   242.              ':',  '=',  '(',  ')',  '£',  '*',  ',',  '/',
   243.              '0',  '1',  '2',  '3',  '4',  '5',  '6',  '7',
   244.              '8',  '9',  '_',  'º',  ';',  '+',  '-',  '.',
   245.              '@',  'A',  'B',  'C',  'D',  'E',  'F',  'G',
   246.              'H',  'I',  'J',  'K',  'L',  'M',  'N',  'O',
   247.              'P',  'Q',  'R',  'S',  'T',  'U',  'V',  'W',
   248.              'X',  'Y',  'Z',  '{',  '}',  E_M,  '\',  W_F
   249.             );
   250.
   251.    -- Two-shift devices expand the code by adopting alternative representations
   252.    --    depending on the current "shift".
   253.    -- The Flexowriter type cage really did shift up and down
   254.    --    to bring the appropriate glyph set into position.
   255.
   256.    subtype letter_case is KDF9.symbol range KDF9.Blank_Space .. KDF9.Case_Normal;
   257.    both   : constant KDF9.symbol := KDF9.Blank_Space;
   258.    normal : constant KDF9.symbol := KDF9.Case_Normal;
   259.    shift  : constant KDF9.symbol := KDF9.Case_Shift;
   260.
   261.    case_of : constant input_code_table
   262.            := (' ' =>  both,  '"' =>  both,   LF =>  both,   FF =>  both,
   263.                 HT =>  both,  '#' =>  both,  C_S =>  both,  C_N =>  both,
   264.                '&' =>  both,  '?' =>  both,  '!' =>  both,  '%' =>  both,
   265.                ''' =>  both,  '$' =>  both,  '~' =>  both,  ':' => shift,
   266.                '^' => shift,  '[' => shift,  ']' => shift,  '<' => shift,
   267.                '>' => shift,  '=' => shift,  '×' => shift,  '÷' => shift,
   268.                '(' => shift,  ')' => shift,  '_' =>  both,  '£' => shift,
   269.                ';' =>  both,  '±' => shift,  '*' => shift,  ',' => shift,
   270.
   271.                '@' =>  both,  'a' => shift,  'b' => shift,  'c' => shift,
   272.                'd' => shift,  'e' => shift,  'f' => shift,  'g' => shift,
   273.                'h' => shift,  'i' => shift,  'j' => shift,  'k' => shift,
   274.                'l' => shift,  'm' => shift,  'n' => shift,  'o' => shift,
   275.                'p' => shift,  'q' => shift,  'r' => shift,  's' => shift,
   276.                't' => shift,  'u' => shift,  'v' => shift,  'w' => shift,
   277.                'x' => shift,  'y' => shift,  'z' => shift,  '{' =>  both,
   278.                '}' =>  both,  E_M =>  both,  '\' =>  both,  W_F =>  both,
   279.                others => normal
   280.               );
   281.
   282.    next_case : constant array (shift .. normal) of Character := (normal => C_S, shift => C_N);
   283.
   284.    -- The Case Normal shift paper tape code:
   285.    TP_CN : constant output_code_table
   286.          := (' ',  '"',   LF,   FF,   HT,  '#',  C_S,  C_N,
   287.              '&',  '?',  '!',  '%',  ''',  '$',  '~',  '/',
   288.              '0',  '1',  '2',  '3',  '4',  '5',  '6',  '7',
   289.              '8',  '9',  '_',  'º',  ';',  '+',  '-',  '.',
   290.              '@',  'A',  'B',  'C',  'D',  'E',  'F',  'G',
   291.              'H',  'I',  'J',  'K',  'L',  'M',  'N',  'O',
   292.              'P',  'Q',  'R',  'S',  'T',  'U',  'V',  'W',
   293.              'X',  'Y',  'Z',  '{',  '}',  E_M,  '\',  W_F
   294.             );
   295.
   296.    CN_TR : constant input_code_table
   297.          := (' ' => 8#00#,  '"' => 8#01#,   LF => 8#02#,   FF => 8#03#,
   298.               HT => 8#04#,  '#' => 8#05#,  C_S => 8#06#,  C_N => 8#07#,
   299.              '&' => 8#10#,  '?' => 8#11#,  '!' => 8#12#,  '%' => 8#13#,
   300.              ''' => 8#14#,  '$' => 8#15#,  '~' => 8#16#,  '/' => 8#17#,
   301.              '0' => 8#20#,  '1' => 8#21#,  '2' => 8#22#,  '3' => 8#23#,
   302.              '4' => 8#24#,  '5' => 8#25#,  '6' => 8#26#,  '7' => 8#27#,
   303.              '8' => 8#30#,  '9' => 8#31#,  '_' => 8#32#,  'º' => 8#33#,
   304.              ';' => 8#34#,  '+' => 8#35#,  '-' => 8#36#,  '.' => 8#37#,
   305.              '@' => 8#40#,  'A' => 8#41#,  'B' => 8#42#,  'C' => 8#43#,
   306.              'D' => 8#44#,  'E' => 8#45#,  'F' => 8#46#,  'G' => 8#47#,
   307.              'H' => 8#50#,  'I' => 8#51#,  'J' => 8#52#,  'K' => 8#53#,
   308.              'L' => 8#54#,  'M' => 8#55#,  'N' => 8#56#,  'O' => 8#57#,
   309.              'P' => 8#60#,  'Q' => 8#61#,  'R' => 8#62#,  'S' => 8#63#,
   310.              'T' => 8#64#,  'U' => 8#65#,  'V' => 8#66#,  'W' => 8#67#,
   311.              'X' => 8#70#,  'Y' => 8#71#,  'Z' => 8#72#,  '{' => 8#73#,
   312.              '}' => 8#74#,  E_M => 8#75#,  '\' => 8#76#,  W_F => 8#77#,
   313.              others => 0  -- This must be zero.
   314.             );
   315.
   316.    -- The Case Shift paper tape code:
   317.    TP_CS : constant output_code_table
   318.          := (' ',  '"',   LF,   FF,   HT,  '#',  C_S,  C_N,
   319.              '&',  '?',  '!',  '%',  ''',  '$',  '~',  ':',
   320.              '^',  '[',  ']',  '<',  '>',  '=',  '×',  '÷',
   321.              '(',  ')',  '_',  '£',  ';',  '±',  '*',  ',',
   322.              '@',  'a',  'b',  'c',  'd',  'e',  'f',  'g',
   323.              'h',  'i',  'j',  'k',  'l',  'm',  'n',  'o',
   324.              'p',  'q',  'r',  's',  't',  'u',  'v',  'w',
   325.              'x',  'y',  'z',  '{',  '}',  E_M,  '\',  W_F
   326.             );
   327.
   328.    CS_TR : constant input_code_table
   329.          := (' ' => 8#00#,  '"' => 8#01#,   LF => 8#02#,   FF => 8#03#,
   330.               HT => 8#04#,  '#' => 8#05#,  C_S => 8#06#,  C_N => 8#07#,
   331.              '&' => 8#10#,  '?' => 8#11#,  '!' => 8#12#,  '%' => 8#13#,
   332.              ''' => 8#14#,  '$' => 8#15#,  '~' => 8#16#,  ':' => 8#17#,
   333.              '^' => 8#20#,  '[' => 8#21#,  ']' => 8#22#,  '<' => 8#23#,
   334.              '>' => 8#24#,  '=' => 8#25#,  '×' => 8#26#,  '÷' => 8#27#,
   335.              '(' => 8#30#,  ')' => 8#31#,  '_' => 8#32#,  '£' => 8#33#,
   336.              ';' => 8#34#,  '±' => 8#35#,  '*' => 8#36#,  ',' => 8#37#,
   337.              '@' => 8#40#,  'a' => 8#41#,  'b' => 8#42#,  'c' => 8#43#,
   338.              'd' => 8#44#,  'e' => 8#45#,  'f' => 8#46#,  'g' => 8#47#,
   339.              'h' => 8#50#,  'i' => 8#51#,  'j' => 8#52#,  'k' => 8#53#,
   340.              'l' => 8#54#,  'm' => 8#55#,  'n' => 8#56#,  'o' => 8#57#,
   341.              'p' => 8#60#,  'q' => 8#61#,  'r' => 8#62#,  's' => 8#63#,
   342.              't' => 8#64#,  'u' => 8#65#,  'v' => 8#66#,  'w' => 8#67#,
   343.              'x' => 8#70#,  'y' => 8#71#,  'z' => 8#72#,  '{' => 8#73#,
   344.              '}' => 8#74#,  E_M => 8#75#,  '\' => 8#76#,  W_F => 8#77#,
   345.              others => 0  -- This must be zero.
   346.             );
   347.
   348.    --
   349.    -- These types define the structure of the KDF9's programmable registers.
   350.    --
   351.    type nest_depth is mod 19;
   352.    for  nest_depth'Size use 32;
   353.    type nest    is array (KDF9.nest_depth) of KDF9.word;
   354.
   355.    type sjns_depth is mod 17;
   356.    for  sjns_depth'Size use 32;
   357.    type sjns    is array (KDF9.sjns_depth) of KDF9.code_link;
   358.
   359.    type Q_store is array (KDF9.Q_number)  of KDF9.Q_register;
   360.
   361. --
   362.    -- The following variables (the_nest, the_sjns and the_Q_store) are
   363.    --    the emulation microcode's working set (unlike the real KDF9).
   364. --
   365.
   366.    --
   367.    -- The NEST.
   368.    --
   369.
   370.    the_nest       : KDF9.nest;
   371.    the_nest_depth : KDF9.nest_depth  := 0;
   372.
   373.    -- check_whether_the_nest_holds* does not cause NOUV if the_authenticity_mode = lax_mode.
   374.    procedure check_whether_the_nest_holds (at_least : in KDF9.nest_depth);
   375.    pragma Inline(check_whether_the_nest_holds);
   376.
   377.    procedure check_whether_the_nest_holds_an_operand;
   378.    pragma Inline(check_whether_the_nest_holds_an_operand);
   379.
   380.    procedure check_whether_the_nest_holds_2_operands;
   381.    pragma Inline(check_whether_the_nest_holds_2_operands);
   382.
   383.    -- ensure_that_the_nest_holds* ignores the_authenticity_mode.
   384.    procedure ensure_that_the_nest_holds (at_least : in KDF9.nest_depth);
   385.    pragma Inline(ensure_that_the_nest_holds);
   386.
   387.    procedure ensure_that_the_nest_holds_an_operand;
   388.    pragma Inline(ensure_that_the_nest_holds_an_operand);
   389.
   390.    procedure ensure_that_the_nest_holds_2_operands;
   391.    pragma Inline(ensure_that_the_nest_holds_2_operands);
   392.
   393.    procedure ensure_that_the_nest_has_room_for (at_least : in KDF9.nest_depth);
   394.    pragma Inline(ensure_that_the_nest_has_room_for);
   395.
   396.    procedure ensure_that_the_nest_has_room_for_a_result;
   397.    pragma Inline(ensure_that_the_nest_has_room_for_a_result);
   398.
   399.    procedure ensure_that_the_nest_has_room_for_2_results;
   400.    pragma Inline(ensure_that_the_nest_has_room_for_2_results);
   401.
   402.    procedure push (the_word : in KDF9.word);
   403.
   404.    function pop
   405.    return KDF9.word;
   406.
   407.    procedure pop;
   408.
   409.    procedure write_top (the_word : in KDF9.word);
   410.
   411.    function read_top
   412.    return KDF9.word;
   413.
   414.    procedure push (the_pair : in KDF9.pair);
   415.
   416.    function pop
   417.    return KDF9.pair;
   418.
   419.    procedure write_top (the_pair : in KDF9.pair);
   420.
   421.    function read_top
   422.    return KDF9.pair;
   423.
   424.    pragma Inline(push);
   425.    pragma Inline(pop);
   426.    pragma Inline(write_top);
   427.    pragma Inline(read_top);
   428.
   429.    --
   430.    -- The SJNS.
   431.    --
   432.
   433.    the_sjns       : KDF9.sjns;
   434.    the_sjns_depth : KDF9.sjns_depth := 0;
   435.
   436.    procedure ensure_that_the_sjns_is_not_empty;
   437.    pragma Inline(ensure_that_the_sjns_is_not_empty);
   438.
   439.    procedure ensure_that_the_sjns_is_not_full;
   440.    pragma Inline(ensure_that_the_sjns_is_not_full);
   441.
   442.    procedure push (the_link : in KDF9.code_point);
   443.    pragma Inline(push);
   444.
   445.    function pop
   446.    return KDF9.code_point;
   447.    pragma Inline(pop);
   448.
   449.    function sjns_top
   450.    return KDF9.code_link;
   451.
   452.
   453.    --
   454.    -- The Q Store.
   455.    --
   456.
   457.    -- Q0 is set to zero after every Q store updating order, to keep it permanently zeroised.
   458.    the_Q_store : KDF9.Q_store;
   459.
   460.    --
   461.    -- The Boolean registers.
   462.    --
   463.
   464.    the_V_bit : KDF9.word := 0;
   465.    the_T_bit : KDF9.word := 0;
   466.
   467.
   468. --
   469.    -- The following are to do with maintaining the virtual time.
   470. --
   471.
   472.    -- The emulation clocks tick in microseconds (unlike KDF9's clock).
   473.    type microseconds is mod 2**64;
   474.
   475.    -- The virtual processor time.
   476.    the_CPU_time      : KDF9.microseconds := 0;
   477.
   478.    -- The amount by which the_CPU_time is increased by an instruction execution.
   479.    the_CPU_delta     : KDF9.microseconds := 0;
   480.
   481.    -- The virtual elapsed time.
   482.    -- Cap the result to prevent a spurious double-clock (RESET) interrupt.
   483.    function the_clock_time return KDF9.microseconds;
   484.    pragma Inline(the_clock_time);
   485.
   486.    -- Advance to the max of the_CPU_time, the_elapsed_time, the_last_delay_time, and this_time.
   487.    -- Cap the increase to prevent a spurious double-clock (RESET) interrupt in Director.
   488.    -- If necessary, pause execution until the real time equals the virtual elapsed time.
   489.    procedure advance_the_clock_past (this_time : in KDF9.microseconds);
   490.
   491.    -- The virtual clock time at which the next IO interrupt is expected.
   492.    the_next_interrupt_time : KDF9.microseconds := KDF9.microseconds'Last;
   493.
   494.    -- Pause execution for the_delay_time in virtual microseconds.
   495.    procedure delay_by (the_delay_time : in KDF9.microseconds);
   496.
   497.    -- If necessary, pause execution until the real time equals the virtual elapsed time.
   498.    procedure synchronize_the_real_and_virtual_times;
   499.
   500.
   501. --
   502.    -- The following register types are used only in Director state.
   503. --
   504.
   505.    --
   506.    -- The following are to do with the K1 order.
   507.    --
   508.    type priority is mod 2**2;
   509.
   510.    -- This is the priority level of the currently-executing problem program.
   511.    CPL : KDF9.priority;
   512.
   513.    -- BA = word address of first allocated word (NOT group number as in the KDF9).
   514.    BA  : KDF9.address;
   515.
   516.    -- NOL = word address of last allocated word (NOT group number as in the KDF9).
   517.    NOL : KDF9.address;
   518.
   519.    -- Set BA (setting bits D38:47), CPL (D34:35) and NOL (D24:33).
   520.    procedure set_K1_register (setting : in KDF9.word);
   521.
   522.    --
   523.    -- The following are to do with the =K2 order.
   524.    --
   525.    type one_bit is mod 2;
   526.
   527.    -- The Current Peripheral Device Allocation Register.
   528.    type CPDAR is array (KDF9.buffer_number) of KDF9.one_bit;
   529.    pragma Convention(C, CPDAR);
   530.
   531.    the_CPDAR : KDF9.CPDAR;
   532.
   533.    -- Set CPDAR (setting bits D32 .. D47).
   534.    procedure set_K2_register (setting : in KDF9.word);
   535.
   536.    --
   537.    -- The following are to do with the =K3 and K7 orders.
   538.    --
   539.    type user_register_set is
   540.       record
   541.          nest     : KDF9.nest;
   542.          sjns     : KDF9.sjns;
   543.          Q_store  : KDF9.Q_store;
   544.       end record;
   545.
   546.    -- There are 4 sets of user registers.
   547.    -- The execution context is the number of the register set in active use.
   548.    type context is mod 2**2;
   549.
   550.    -- register_bank holds the currently inactive register sets.
   551.    register_bank : array(KDF9.context) of KDF9.user_register_set;
   552.
   553.    -- KDF9 actually indexed the register bank with the value of the_context,
   554.    --   but the emulator swaps register sets between register_bank and
   555.    --      the_nest, the_sjns, and the_Q_store (q.v.).
   556.
   557.    the_context : KDF9.context := 0;
   558.
   559.    -- Set context (bits D46:47), nest_depth (D41:45) and sjns_depth (D36:41).
   560.    procedure set_K3_register (setting : in KDF9.word);
   561.
   562.    -- Get BA (bits D0 .. D9), CPL (D12 .. D13) and NOL (D14 .. D23).
   563.    function get_K7_operand
   564.    return KDF9.word;
   565.
   566.    --
   567.    -- The following are to do with the K4 order.
   568.    --
   569.    type interrupt_number is range 22 .. 31;
   570.
   571.    -- higher PRiority unblocked by end of I/O, or INTQq on busy device
   572.    PR_flag    : constant KDF9.interrupt_number := 22;
   573.    PR_trap    : exception;
   574.
   575.    -- FLEXowriter interrupt from operator
   576.    FLEX_flag  : constant KDF9.interrupt_number := 23;
   577.    FLEX_trap  : exception;
   578.
   579.    -- Lock-In Violation (attempt at a disallowed operation)
   580.    LIV_flag   : constant KDF9.interrupt_number := 24;
   581.    LIV_trap   : exception;
   582.
   583.    -- Nest (or SJNS) Over/Underflow Violation
   584.    NOUV_flag  : constant KDF9.interrupt_number := 25;
   585.    NOUV_trap  : exception;
   586.
   587.    -- End of Director Transfer, or I/O priority inversion
   588.    EDT_flag   : constant KDF9.interrupt_number := 26;
   589.    EDT_trap   : exception;
   590.
   591.    -- OUT system call
   592.    OUT_flag   : constant KDF9.interrupt_number := 27;
   593.    OUT_trap   : exception;
   594.
   595.    -- Lock-Out Violation
   596.    LOV_flag   : constant KDF9.interrupt_number := 28;
   597.    LOV_trap   : exception;
   598.
   599.    -- invalid syllable number or 'double-clock'
   600.    RESET_flag : constant KDF9.interrupt_number := 29;
   601.    RESET_trap : exception;
   602.
   603.    type RFIR is array (KDF9.interrupt_number) of Boolean;
   604.
   605.    the_RFIR : KDF9.RFIR := (others => False);
   606.
   607.     -- The time at which the last K4 order was executed.
   608.    the_last_K4_time : KDF9.microseconds := 0;
   609.
   610.    -- Get clock (bits D0:15) and RFIR (D16:31), clearing both.
   611.    function get_K4_operand
   612.    return KDF9.word;
   613.
   614.    --
   615.    -- The following are to do with the K5 order.
   616.    --
   617.
   618.    -- The Program Hold-Up register is internal to I/O Control.
   619.    -- Get PHUi (bits D6i .. 6i+5), i = 0 .. 3.
   620.    function get_K5_operand
   621.    return KDF9.word;
   622.
   623.
   624. --
   625.    -- The following are to do with management of the CPU's internal state.
   626. --
   627.    type CPU_state is (Director_state, program_state);
   628.
   629.    the_CPU_state : KDF9.CPU_state;
   630.
   631.    procedure reset_the_CPU_state;
   632.
   633.    procedure reset_the_internal_registers (the_new_state : in CPU_state := Director_state);
   634.
   635.    procedure LIV_if_user_mode (the_reason : in String := "Director-only instruction");
   636.
   637.    procedure LOV_if_user_mode;
   638.
   639.    procedure change_to_user_state_at (new_IAR : in KDF9.code_point);
   640.
   641.    procedure signal_interrupt (the_reason : in KDF9.interrupt_number);
   642.
   643.    procedure trap_invalid_instruction (the_message : in String := "invalid instruction");
   644.
   645.    procedure reset_the_program_state;
   646.
   647. --
   648.    -- Instruction fetch and decode.
   649. --
   650.
   651.    -- These Instruction Address Registers are the nearest KDF9 has
   652.    --    to a conventional 'Program Counter' register.
   653.    -- NIA is significant only after an instruction has been decoded.
   654.
   655.    function NIA return KDF9.code_point;  -- the Next Instruction Address
   656.    pragma Inline(NIA);
   657.
   658.    function NIA_word_number return KDF9.code_location;
   659.    pragma Inline(NIA_word_number);
   660.
   661.    CIA : KDF9.code_point;                -- the Current Instruction Address
   662.
   663.    -- IWB0 and IWB1 in KDF9 contained the current 2 instruction words.
   664.    -- A 'short' loop, initiated by the JCqNZS instruction, ran entirely
   665.    --    inside the IWBs, obviating repeated instruction-fetch overhead.
   666.    -- Director exploits this in a loop that zeroizes the whole of core,
   667.    --    including that loop, which runs, immune to overwriting, in the IWBs.
   668.
   669.    procedure set_NIA_to (new_NIA : in KDF9.code_point);
   670.    pragma Inline(set_NIA_to);
   671.
   672.    procedure set_NIA_to_the_INS_target_address;
   673.
   674.    procedure set_IWB0_and_IWB1_for_a_JCqNZS_loop;
   675.    pragma Inline(set_IWB0_and_IWB1_for_a_JCqNZS_loop);
   676.
   677.    procedure go_back_to_the_start_of_IWB0;
   678.    pragma Inline(go_back_to_the_start_of_IWB0);
   679.
   680.    procedure continue_after_JCqNZS;
   681.    pragma Inline(continue_after_JCqNZS);
   682.
   683.    -- Bits 0-1 of every order indicates its type as follows.
   684.    type INS_kind is mod 2**2;
   685.
   686.    one_syllable_order : constant := 0;
   687.    two_syllable_order : constant := 1;
   688.    normal_jump_order  : constant := 2;
   689.    data_access_order  : constant := 3;
   690.
   691.    type decoded_order is
   692.       record
   693.          order : KDF9.syllable_group := (0, 0, 0);
   694.          kind  : KDF9.INS_kind := 0;
   695.
   696.          -- The syndrome is:
   697.          --    bits 2-7 of 1- and 2-syllable orders
   698.          --    bits 2-3|8-11 of normal jumps
   699.          --    bits 5-7 of SET and directly-addressed store access orders.
   700.          -- See the compressed_opcodes package.
   701.          syndrome : KDF9.syndrome := 0;
   702.
   703.           -- Qq is bits 8-11, Qk is bits 12-15.
   704.          Qq, Qk : KDF9.Q_number := 0;
   705.
   706.          -- For an jump instruction, syllable_number is bits 5-7.
   707.          target : code_point;
   708.
   709.          -- For a data address or value (SET), operand is bits 2-4|12-23.
   710.          operand : KDF9.Q_part := 0;
   711.       end record;
   712.
   713.    INS : KDF9.decoded_order;  -- analogous to the INS register in Main Control
   714.
   715.    -- After decode_the_next_order:
   716.    --    INS contains the whole instruction at the address given by CIA,
   717.    --       with its components unpacked.
   718.    procedure decode_the_next_order;
   719.    pragma Inline(decode_the_next_order);
   720.
   721.    procedure decode (the_order : in out KDF9.decoded_order);
   722.    pragma Inline(decode);
   723.
   724.    procedure process_syllable_0_of_INS;
   725.    pragma Inline(process_syllable_0_of_INS);
   726.
   727.    procedure process_syllable_1_of_INS;
   728.    pragma Inline(process_syllable_1_of_INS);
   729.
   730.    procedure process_syllables_1_and_2_of_a_jump_order;
   731.    pragma Inline(process_syllables_1_and_2_of_a_jump_order);
   732.
   733.    procedure process_syllables_1_and_2_of_a_data_access_order;
   734.    pragma Inline(process_syllables_1_and_2_of_a_data_access_order);
   735.
   736.    -- the_order_at_NIA gets three syllables starting at [NIA].  It is FOR DIAGNOSTIC USE ONLY!
   737.    -- It does NOT update the CPU time properly and must not be used inside an instruxtion cycle.
   738.    function the_order_at_NIA
   739.    return KDF9.syllable_group;
   740.    pragma Inline(the_order_at_NIA);
   741.
   742.    -- Save E0U, lest the initial jump in E0 be corrupted during the run.
   743.    procedure save_the_initial_jump;
   744.
   745.    -- Restore E0U to its saved value.
   746.    procedure restore_the_initial_jump;
   747.
   748.    -- Check whether E0U has changed.
   749.    function the_initial_jump_was_corrupted
   750.    return Boolean;
   751.
   752.    -- True if the parameter is not a valid KDF9 instruction.
   753.    function is_an_invalid_order (decoded : KDF9.decoded_order)
   754.    return Boolean;
   755.
   756.
   757. --
   758.    -- The Instruction Counter Register (N.B. NOT a 'PROGRAM counter')
   759.    --   indicates the number of instructions executed by the KDF9.
   760. --
   761.
   762.    type order_counter is mod 2**64;
   763.
   764.    ICR : KDF9.order_counter := 0;
   765.
   766.
   767. --
   768.    -- The following support hashed execution-signature checking,
   769.    --    mainly for self-checking of new versions and ports.
   770. --
   771.
   772.    function the_digital_signature
   773.    return KDF9.word;
   774.
   775.    procedure update_the_digital_signature;
   776.    pragma Inline(update_the_digital_signature);
   777.
   778.
   779. --
   780.    -- These should be in IOC, but are put here to break cyclic dependencies.
   781. --
   782.
   783.    subtype logical_device_name is String(1 .. 3);
   784.
   785.    FD0_number : constant := 14; -- Fixed Disc buffer number, used in several places.
   786.
   787.
   788. private
   789.
   790.    the_elapsed_time    : KDF9.microseconds := 0;
   791.    the_last_delay_time : KDF9.microseconds := 0;
   792.
   793.    fetching_normally   : Boolean := True;
   794.
   795. end KDF9;

 990 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\kdf9-microcode.adb
Source file time stamp: 2015-06-18 00:56:08
Compiled at: 2015-10-28 18:13:48

     1. -- kdf9-microcode.adb
     2. --
     3. -- KDF9 ISP emulation - CPU microcode routines.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with exceptions;
    20. with IOC;
    21. with IOC.assignment;
    22. with KDF9.compressed_opcodes;
    23. with KDF9.CPU;
    24. with KDF9.Directors;
    25. with KDF9.store;
    26. with POSIX;
    27. with settings;
    28. with state_display;
    29. with tracing;
    30.
    31. use  exceptions;
    32. use  IOC;
    33. use  IOC.assignment;
    34. use  KDF9.compressed_opcodes;
    35. use  KDF9.CPU;
    36. use  KDF9.Directors;
    37. use  KDF9.store;
    38. use  settings;
    39. use  state_display;
    40. use  tracing;
    41.
    42. package body KDF9.microcode is
    43.
    44.    procedure do_a_one_syllable_order is
    45.       A, B, C, E : KDF9.word;
    46.       AB, CD     : KDF9.pair;
    47.       X, Y       : CPU.float;
    48.       XY, ZT     : CPU.double;
    49.    begin
    50.       case INS.syndrome is
    51.
    52.          when VR =>
    53.             the_V_bit := 0;
    54.             the_CPU_delta := the_CPU_delta + 1;
    55.
    56.          when TO_TR =>
    57.             ensure_that_the_nest_holds_an_operand;
    58.             if resign(pop) < 0 then
    59.                the_T_bit := 1;
    60.             end if;
    61.             the_CPU_delta := the_CPU_delta + 2;
    62.
    63.          when BITS =>
    64.             check_whether_the_nest_holds_an_operand;
    65.             write_top(cardinality(read_top));
    66.             the_CPU_delta := the_CPU_delta + 27;
    67.
    68.          when XF =>
    69.             ensure_that_the_nest_holds_2_operands;
    70.             X := pop;
    71.             Y := read_top;
    72.             write_top(CPU.float'(Y * X));
    73.             the_CPU_delta := the_CPU_delta + 15;
    74.
    75.          when XDF =>
    76.             ensure_that_the_nest_holds_2_operands;
    77.             XY := read_top;
    78.             ZT := XY.lsw * XY.msw;
    79.             write_top(ZT);
    80.             the_CPU_delta := the_CPU_delta + 16;
    81.
    82.          when XPLUSF =>
    83.             ensure_that_the_nest_holds(at_least => 4);
    84.             XY := pop;
    85.             ZT := XY.lsw * XY.msw;
    86.             XY := read_top;
    87.             write_top(XY + ZT);
    88.             the_CPU_delta := the_CPU_delta + 18;
    89.
    90.          when NEGD =>
    91.             check_whether_the_nest_holds_2_operands;
    92.             AB := read_top;
    93.             write_top( - AB);
    94.             the_CPU_delta := the_CPU_delta + 2;
    95.
    96.          when OR_9 =>
    97.             ensure_that_the_nest_holds_2_operands;
    98.             A := pop;
    99.             write_top(read_top or A);
   100.             the_CPU_delta := the_CPU_delta + 1;
   101.
   102.          when PERM =>
   103.             check_whether_the_nest_holds(at_least => 3);
   104.             A := pop;
   105.             CD := pop;
   106.             push(A);
   107.             push(CD);
   108.             the_CPU_delta := the_CPU_delta + 2;
   109.
   110.          when TOB =>
   111.             ensure_that_the_nest_holds_2_operands;
   112.             A := pop;
   113.             B := read_top;
   114.             C := 0;
   115.             for i in 1 .. 8 loop
   116.                A := rotate_word_left(A, 6);
   117.                B := rotate_word_left(B, 6);
   118.                C := C*(B and 8#77#) + (A and 8#77#);
   119.             end loop;
   120.             write_top(C);
   121.             the_CPU_delta := the_CPU_delta + 27;
   122.
   123.          when ROUNDH =>
   124.             check_whether_the_nest_holds_an_operand;
   125.             A := read_top;
   126.             write_top(resign(A) + 2**23);
   127.             the_CPU_delta := the_CPU_delta + 22;
   128.
   129.          when NEV =>
   130.             ensure_that_the_nest_holds_2_operands;
   131.             A := pop;
   132.             write_top(read_top xor A);
   133.             the_CPU_delta := the_CPU_delta + 2;
   134.
   135.          when ROUND =>
   136.             ensure_that_the_nest_holds_2_operands;
   137.             A := pop;
   138.             write_top(resign(A) + resign(shift_word_right(read_top, 46) and 1));
   139.             the_CPU_delta := the_CPU_delta + 1;
   140.
   141.          when DUMMY =>
   142.             the_CPU_delta := the_CPU_delta + 1;
   143.
   144.          when ROUNDF =>
   145.             ensure_that_the_nest_holds_2_operands;
   146.             XY := pop;
   147.             ZT := XY;
   148.             push(rounded(XY));
   149.             the_CPU_delta := the_CPU_delta + 3;
   150.
   151.          when ROUNDHF =>
   152.             check_whether_the_nest_holds_an_operand;
   153.             X := pop;
   154.             push(rounded(X));
   155.             the_CPU_delta := the_CPU_delta + 3;
   156.
   157.          when MINUSDF =>
   158.             ensure_that_the_nest_holds(at_least => 4);
   159.             XY := pop;
   160.             ZT := read_top;
   161.             write_top(ZT - XY);
   162.             the_CPU_delta := the_CPU_delta + 12;
   163.
   164.          when PLUSDF =>
   165.             ensure_that_the_nest_holds(at_least => 4);
   166.             XY := pop;
   167.             ZT := read_top;
   168.             write_top(ZT + XY);
   169.             the_CPU_delta := the_CPU_delta + 12;
   170.
   171.          when FLOAT_9 =>
   172.             ensure_that_the_nest_holds_2_operands;
   173.             A := pop;
   174.             B := read_top;
   175.             write_top(KDF9.word(normalized(full_fraction => B, scaler => A)));
   176.             the_CPU_delta := the_CPU_delta + 7;
   177.
   178.          when FLOATD =>
   179.             ensure_that_the_nest_holds(at_least => 3);
   180.             A := pop;
   181.             CD := read_top;
   182.             -- See §3.4 of Report K/GD.y.83, dated 6/12/1962.
   183.             CD.lsw := CD.lsw and not 8#77#;  -- The 6 l.s.b. are lost.
   184.             reconstruct(CD, scaler => A);
   185.             write_top(CD);
   186.             the_CPU_delta := the_CPU_delta + 8;
   187.
   188.          when ABS_9 =>
   189.             check_whether_the_nest_holds_an_operand;
   190.             write_top( abs resign(read_top));
   191.             the_CPU_delta := the_CPU_delta + 1;
   192.
   193.          when NEG =>
   194.             check_whether_the_nest_holds_an_operand;
   195.             write_top( - resign(read_top));
   196.             the_CPU_delta := the_CPU_delta + 1;
   197.
   198.          when ABSF =>
   199.             check_whether_the_nest_holds_an_operand;
   200.             X := read_top;
   201.             if resign(KDF9.word(X)) < 0 then
   202.                write_top( - X);
   203.                the_CPU_delta := the_CPU_delta + 4;
   204.             else
   205.                the_CPU_delta := the_CPU_delta + 1;
   206.             end if;
   207.
   208.          when NEGF =>
   209.             check_whether_the_nest_holds_an_operand;
   210.             X := read_top;
   211.             write_top( - X);
   212.             the_CPU_delta := the_CPU_delta + 3;
   213.
   214.          when MAX =>
   215.             check_whether_the_nest_holds_2_operands;
   216.             AB := read_top;
   217.             if resign(AB.lsw) >= resign(AB.msw) then
   218.                write_top(KDF9.pair'(msw => AB.lsw, lsw =>AB.msw));
   219.                the_V_bit := 1;
   220.             end if;
   221.             the_CPU_delta := the_CPU_delta + 4;
   222.
   223.          when NOT_9 =>
   224.             check_whether_the_nest_holds_an_operand;
   225.             A := read_top;
   226.             write_top(not A);
   227.             the_CPU_delta := the_CPU_delta + 1;
   228.
   229.          when XD =>
   230.             AB := read_top;
   231.             CD := AB.msw * AB.lsw;
   232.             write_top(CD);
   233.             the_CPU_delta := the_CPU_delta + 14;
   234.
   235.          when X_frac =>
   236.             ensure_that_the_nest_holds_2_operands;
   237.             A := pop;
   238.             write_top(integral(CPU.fraction'(read_top * A)));
   239.             the_CPU_delta := the_CPU_delta + 15;
   240.
   241.          when MINUS =>
   242.             ensure_that_the_nest_holds_2_operands;
   243.             A := pop;
   244.             B := read_top;
   245.             write_top(resign(B) - resign(A));
   246.             the_CPU_delta := the_CPU_delta + 1;
   247.
   248.          when SIGN =>
   249.             ensure_that_the_nest_holds_2_operands;
   250.             A := pop;
   251.             B := read_top;
   252.             if B = A then
   253.                write_top(KDF9.word'(0));
   254.             elsif resign(B) > resign(A) then
   255.                write_top(KDF9.word'(1));
   256.             else
   257.                write_top(all_one_bits);
   258.             end if;
   259.             the_CPU_delta := the_CPU_delta + 3;
   260.
   261.          when ZERO =>
   262.             ensure_that_the_nest_has_room_for_a_result;
   263.             push(all_zero_bits);
   264.             the_CPU_delta := the_CPU_delta + 2;
   265.
   266.          when DUP =>
   267.             check_whether_the_nest_holds_an_operand;
   268.             ensure_that_the_nest_has_room_for_a_result;
   269.             A := read_top;
   270.             push(A);
   271.             the_CPU_delta := the_CPU_delta + 2;
   272.
   273.          when DUPD =>
   274.             check_whether_the_nest_holds_2_operands;
   275.             ensure_that_the_nest_has_room_for_2_results;
   276.             AB := read_top;
   277.             push(AB);
   278.             the_CPU_delta := the_CPU_delta + 4;
   279.
   280.          when DIVI =>
   281.             check_whether_the_nest_holds_2_operands;
   282.             AB := read_top;
   283.             do_DIVI(L => AB.lsw,
   284.                     R => AB.msw,
   285.                     Quotient  => CD.lsw,
   286.                     Remainder => CD.msw);
   287.             write_top(CD);
   288.             the_CPU_delta := the_CPU_delta + 36;
   289.
   290.          when FIX =>
   291.             ensure_that_the_nest_holds_an_operand;
   292.             ensure_that_the_nest_has_room_for_a_result;
   293.             X := read_top;
   294.             write_top(fraction_word(X));
   295.             push(scaler(X));
   296.             the_CPU_delta := the_CPU_delta + 6;
   297.
   298.          when STR =>
   299.             check_whether_the_nest_holds_an_operand;
   300.             ensure_that_the_nest_has_room_for_a_result;
   301.             A := read_top;
   302.             if resign(A) < 0 then
   303.                write_top(A and not_sign_bit);
   304.                push(all_one_bits);
   305.             else
   306.                push(all_zero_bits);
   307.             end if;
   308.             the_CPU_delta := the_CPU_delta + 3;
   309.
   310.          when CONT =>
   311.             ensure_that_the_nest_holds_2_operands;
   312.             A := pop;
   313.             B := read_top;
   314.             write_top(contracted(msw => A, lsw => B));
   315.             the_CPU_delta := the_CPU_delta + 2;
   316.
   317.          when REVD =>
   318.             check_whether_the_nest_holds(at_least => 4);
   319.             AB := pop;
   320.             CD := pop;
   321.             push(AB);
   322.             push(CD);
   323.             the_CPU_delta := the_CPU_delta + 4;
   324.
   325.          when ERASE =>
   326.             ensure_that_the_nest_holds_an_operand;
   327.             pop;
   328.             the_CPU_delta := the_CPU_delta + 1;
   329.
   330.          when MINUSD =>
   331.             ensure_that_the_nest_holds(at_least => 4);
   332.             AB := pop;
   333.             CD := read_top;
   334.             write_top(CD - AB);
   335.             the_CPU_delta := the_CPU_delta + 3;
   336.
   337.          when AND_9 =>
   338.             ensure_that_the_nest_holds_2_operands;
   339.             A := pop;
   340.             write_top(read_top and A);
   341.             the_CPU_delta := the_CPU_delta + 1;
   342.
   343.          when PLUS =>
   344.             ensure_that_the_nest_holds_2_operands;
   345.             A := pop;
   346.             B := read_top;
   347.             write_top(resign(B) + resign(A));
   348.             the_CPU_delta := the_CPU_delta + 1;
   349.
   350.          when PLUSD =>
   351.             ensure_that_the_nest_holds(at_least => 4);
   352.             AB := pop;
   353.             CD := read_top;
   354.             write_top(CD + AB);
   355.             the_CPU_delta := the_CPU_delta + 3;
   356.
   357.          when DIV =>
   358.             ensure_that_the_nest_holds_2_operands;
   359.             AB := pop;
   360.             push(integral(CPU.fraction'(AB.lsw / AB.msw)));
   361.             the_CPU_delta := the_CPU_delta + 36;
   362.
   363.          when DIVD =>
   364.             ensure_that_the_nest_holds(at_least => 3);
   365.             A := pop;
   366.             CD := pop;
   367.             do_DIVD(L => CD,
   368.                     R => A,
   369.                     Q => E);
   370.             push(E);
   371.             the_CPU_delta := the_CPU_delta + 36;
   372.
   373.          when DIVF =>
   374.             check_whether_the_nest_holds_2_operands;
   375.             X := pop;
   376.             Y := read_top;
   377.             write_top(Y / X);
   378.             the_CPU_delta := the_CPU_delta + 36;
   379.
   380.          when DIVDF =>
   381.             ensure_that_the_nest_holds(at_least => 3);
   382.             Y := pop;
   383.             XY := pop;
   384.             push(XY / Y);
   385.             the_CPU_delta := the_CPU_delta + 35;
   386.
   387.          when DIVR =>
   388.             ensure_that_the_nest_holds(at_least => 3);
   389.             A := pop;
   390.             CD := read_top;
   391.             do_DIVR(L => CD,
   392.                     R => A,
   393.                     Quotient  => AB.msw,
   394.                     Remainder => AB.lsw);
   395.             write_top(AB);
   396.             the_CPU_delta := the_CPU_delta + 36;
   397.
   398.          when REV =>
   399.             check_whether_the_nest_holds_2_operands;
   400.             AB := read_top;
   401.             write_top(KDF9.pair'(msw => AB.lsw, lsw =>AB.msw));
   402.             the_CPU_delta := the_CPU_delta + 1;
   403.
   404.          when CAB =>
   405.             check_whether_the_nest_holds(at_least => 3);
   406.             AB := pop;
   407.             C := pop;
   408.             push(AB);
   409.             push(C);
   410.             the_CPU_delta := the_CPU_delta + 2;
   411.
   412.          when FRB =>
   413.             ensure_that_the_nest_holds_2_operands;
   414.             A := pop;
   415.             B := read_top;
   416.             C := 0;
   417.             for i in 1 .. 8 loop
   418.                C := C or (A mod (B and 8#77#));
   419.                A := KDF9.word'(A / (B and 8#77#));
   420.                B := shift_word_right(B, 6);
   421.                C := rotate_word_right(C, 6);
   422.             end loop;
   423.             write_top(C);
   424.             the_CPU_delta := the_CPU_delta + 30;
   425.
   426.          when STAND =>
   427.             check_whether_the_nest_holds_an_operand;
   428.             X := read_top;
   429.             write_top(normalized(X));
   430.             the_CPU_delta := the_CPU_delta + 5;
   431.
   432.          when NEGDF =>
   433.             check_whether_the_nest_holds_2_operands;
   434.             XY := read_top;
   435.             write_top( - XY);
   436.             the_CPU_delta := the_CPU_delta + 9;
   437.
   438.          when MAXF =>
   439.             check_whether_the_nest_holds_2_operands;
   440.             XY := read_top;
   441.             if XY.lsw >= XY.msw then
   442.                write_top(CPU.double'(msw => XY.lsw, lsw =>XY.msw));
   443.                the_V_bit := 1;
   444.             end if;
   445.             the_CPU_delta := the_CPU_delta + 6;
   446.
   447.          when PLUSF =>
   448.             ensure_that_the_nest_holds_2_operands;
   449.             X := pop;
   450.             Y := read_top;
   451.             write_top(Y + X);
   452.             the_CPU_delta := the_CPU_delta + 7;
   453.
   454.          when MINUSF =>
   455.             ensure_that_the_nest_holds_2_operands;
   456.             X := pop;
   457.             Y := read_top;
   458.             write_top(Y - X);
   459.             the_CPU_delta := the_CPU_delta + 7;
   460.
   461.          when SIGNF =>
   462.             ensure_that_the_nest_holds_2_operands;
   463.             XY := pop;
   464.             if KDF9.word(XY.lsw) = KDF9.word(XY.msw) then
   465.                push(all_zero_bits);
   466.             elsif XY.lsw < XY.msw then
   467.                push(all_one_bits);
   468.             else
   469.                push(one_in_ls_bit);
   470.             end if;
   471.             the_CPU_delta := the_CPU_delta + 5;
   472.
   473.          when others =>
   474.             trap_invalid_instruction;
   475.
   476.       end case;
   477.    end do_a_one_syllable_order;
   478.
   479.    procedure do_an_IO_order is
   480.       set_offline : constant Boolean         := (INS.Qk and manual_bit) /= 0;
   481.       IO_opcode   : constant KDF9.syndrome   := (INS.Qk and not manual_bit);
   482.       IO_operand  : constant KDF9.Q_register := the_Q_store(INS.Qq);
   483.    begin
   484.       case INS.syndrome is
   485.
   486.          when PARQq =>
   487.             the_CPU_delta := the_CPU_delta + 11;
   488.             PAR(IO_operand, set_offline, the_T_bit);
   489.             the_CPU_delta := the_CPU_delta + 3;
   490.
   491.          when PIAQq_PICQq_CLOQq_TLOQq =>
   492.             the_CPU_delta := the_CPU_delta + 15;
   493.             case IO_opcode is
   494.                when PIAQq_bits =>
   495.                   PIA(IO_operand, set_offline);
   496.                   the_CPU_delta := the_CPU_delta + 7;
   497.                when PICQq_bits =>
   498.                   PIC(IO_operand, set_offline);
   499.                   the_CPU_delta := the_CPU_delta + 7;
   500.                when CLOQq_bits =>
   501.                   LIV_if_user_mode;
   502.                   CLO(IO_operand, set_offline);
   503.                   the_CPU_delta := the_CPU_delta + 1;
   504.                when TLOQq_bits =>
   505.                   TLO(IO_operand, the_T_bit);
   506.                when others =>
   507.                   trap_invalid_instruction;
   508.             end case;
   509.
   510.          when PIBQq_PIDQq =>
   511.             the_CPU_delta := the_CPU_delta + 15;
   512.             case IO_opcode is
   513.                when PIBQq_bits =>
   514.                   PIB(IO_operand, set_offline);
   515.                   the_CPU_delta := the_CPU_delta + 7;
   516.                when PIDQq_bits =>
   517.                   PID(IO_operand, set_offline);
   518.                   the_CPU_delta := the_CPU_delta + 7;
   519.                when others =>
   520.                   trap_invalid_instruction;
   521.             end case;
   522.
   523.          when PIEQq_PIGQq =>
   524.             the_CPU_delta := the_CPU_delta + 15;
   525.             case IO_opcode is
   526.                when PIEQq_bits =>
   527.                   PIE(IO_operand, set_offline);
   528.                   the_CPU_delta := the_CPU_delta + 7;
   529.                when PIGQq_bits =>
   530.                   PIG(IO_operand, set_offline);
   531.                   the_CPU_delta := the_CPU_delta + 7;
   532.                when others =>
   533.                   trap_invalid_instruction;
   534.             end case;
   535.
   536.          when PIFQq_PIHQq =>
   537.             the_CPU_delta := the_CPU_delta + 15;
   538.             case IO_opcode is
   539.                when PIFQq_bits =>
   540.                   PIF(IO_operand, set_offline);
   541.                   the_CPU_delta := the_CPU_delta + 7;
   542.                when PIHQq_bits =>
   543.                   PIH(IO_operand, set_offline);
   544.                   the_CPU_delta := the_CPU_delta + 7;
   545.                when others =>
   546.                   trap_invalid_instruction;
   547.             end case;
   548.
   549.          when PMAQq_PMKQq_INTQq =>
   550.             the_CPU_delta := the_CPU_delta + 11;
   551.             case IO_opcode is
   552.                when PMAQq_bits =>
   553.                   PMA(IO_operand, set_offline);
   554.                when PMKQq_bits =>
   555.                   PMK(IO_operand, set_offline);
   556.                when INTQq_bits =>
   557.                   INT(IO_operand, set_offline);
   558.                when others =>
   559.                   trap_invalid_instruction;
   560.             end case;
   561.
   562.          when CTQq_PMBQq_PMCQq_BUSYQq =>
   563.             the_CPU_delta := the_CPU_delta + 11;
   564.             case IO_opcode is
   565.                when CTQq_bits =>
   566.                   LIV_if_user_mode;
   567.                   CTQ(IO_operand, set_offline);
   568.                   the_CPU_delta := the_CPU_delta + 2;
   569.                when PMBQq_bits =>
   570.                   PMB(IO_operand, set_offline);
   571.                   the_CPU_delta := the_CPU_delta + 3;
   572.                when PMCQq_bits =>
   573.                   PMC(IO_operand, set_offline);
   574.                   the_CPU_delta := the_CPU_delta + 3;
   575.                when BUSYQq_bits =>
   576.                   BUSY(IO_operand, set_offline, the_T_bit);
   577.                   the_CPU_delta := the_CPU_delta + 2;
   578.                when others =>
   579.                   trap_invalid_instruction;
   580.             end case;
   581.
   582.          when PMDQq_PMEQq_PMLQq =>
   583.             the_CPU_delta := the_CPU_delta + 14;
   584.             case IO_opcode is
   585.                when PMDQq_bits =>
   586.                   PMD(IO_operand, set_offline);
   587.                   the_CPU_delta := the_CPU_delta + 5;
   588.                when PMEQq_bits =>
   589.                   PME(IO_operand, set_offline);
   590.                   the_CPU_delta := the_CPU_delta + 5;
   591.                when PMLQq_bits =>
   592.                   PML(IO_operand, set_offline);
   593.                   the_CPU_delta := the_CPU_delta + 5;
   594.                when others =>
   595.                   trap_invalid_instruction;
   596.             end case;
   597.
   598.          when PMFQq =>
   599.             the_CPU_delta := the_CPU_delta + 11;
   600.             PMF(IO_operand, set_offline);
   601.             the_CPU_delta := the_CPU_delta + 3;
   602.
   603.          when PMGQq =>
   604.             LIV_if_user_mode;
   605.             the_CPU_delta := the_CPU_delta + 14;  -- ??
   606.             PMG(IO_operand, set_offline);
   607.
   608.          when PMHQq =>
   609.             LIV_if_user_mode;
   610.             the_CPU_delta := the_CPU_delta + 16;  -- ??
   611.             PMH(IO_operand, set_offline);
   612.
   613.          when POAQq_POCQq_POEQq_POFQq =>
   614.             the_CPU_delta := the_CPU_delta + 15;
   615.             case IO_opcode is
   616.                when POAQq_bits =>
   617.                   POA(IO_operand, set_offline);
   618.                   the_CPU_delta := the_CPU_delta + 7;
   619.                when POCQq_bits =>
   620.                   POC(IO_operand, set_offline);
   621.                   the_CPU_delta := the_CPU_delta + 7;
   622.                when POEQq_bits =>
   623.                   POE(IO_operand, set_offline);
   624.                   the_CPU_delta := the_CPU_delta + 4;
   625.                when POFQq_bits =>
   626.                   POF(IO_operand, set_offline);
   627.                   the_CPU_delta := the_CPU_delta + 4;
   628.                when others =>
   629.                   trap_invalid_instruction;
   630.             end case;
   631.
   632.          when POBQq_PODQq =>
   633.             the_CPU_delta := the_CPU_delta + 15;
   634.             case IO_opcode is
   635.                when POBQq_bits =>
   636.                   POB(IO_operand, set_offline);
   637.                   the_CPU_delta := the_CPU_delta + 7;
   638.                when PODQq_bits =>
   639.                   POD(IO_operand, set_offline);
   640.                   the_CPU_delta := the_CPU_delta + 7;
   641.                when others =>
   642.                   trap_invalid_instruction;
   643.             end case;
   644.
   645.          when POGQq_POLQq =>
   646.             the_CPU_delta := the_CPU_delta + 15;
   647.             case IO_opcode is
   648.                when POGQq_bits =>
   649.                   POG(IO_operand, set_offline);
   650.                   the_CPU_delta := the_CPU_delta + 7;
   651.                when POLQq_bits =>
   652.                   POL(IO_operand, set_offline);
   653.                   the_CPU_delta := the_CPU_delta + 7;
   654.                when others =>
   655.                   trap_invalid_instruction;
   656.             end case;
   657.
   658.          when POHQq_POKQq =>
   659.             the_CPU_delta := the_CPU_delta + 15;
   660.             case IO_opcode is
   661.                when POHQq_bits =>
   662.                   POH(IO_operand, set_offline);
   663.                   the_CPU_delta := the_CPU_delta + 7;
   664.                when POKQq_bits =>
   665.                   POK(IO_operand, set_offline);
   666.                   the_CPU_delta := the_CPU_delta + 7;
   667.                when others =>
   668.                   trap_invalid_instruction;
   669.             end case;
   670.
   671.          when others =>
   672.             trap_invalid_instruction;
   673.       end case;
   674.    end do_an_IO_order;
   675.
   676.    all_zero_Q_store : constant KDF9.Q_register := (C | I | M => 0);
   677.
   678.    procedure ensure_that_Q0_contains_zero (suspect : KDF9.Q_number);
   679.    pragma Inline(ensure_that_Q0_contains_zero);
   680.
   681.    procedure ensure_that_Q0_contains_zero (suspect : KDF9.Q_number) is
   682.    begin
   683.       if suspect /= 0 then
   684.          return;  -- There cannot be a problem.
   685.       end if;
   686.       -- Q0 was updated, so deal with the possibility of a non-zero result.
   687.       if the_Q_store(0) = all_zero_Q_store then
   688.          return;  -- All is well.
   689.       end if;
   690.       if the_authenticity_mode = lax_mode or the_CPU_state = Director_state then
   691.          the_Q_store(0) := all_zero_Q_store;  -- Suppress the assignment to Q0.
   692.       else
   693.          trap_invalid_instruction;
   694.       end if;
   695.    end ensure_that_Q0_contains_zero;
   696.
   697.    procedure auto_increment;
   698.    pragma Inline(auto_increment);
   699.
   700.    procedure auto_increment is
   701.    begin
   702.       the_Q_store(INS.Qq).M := the_Q_store(INS.Qq).M + the_Q_store(INS.Qq).I;
   703.       the_Q_store(INS.Qq).C := the_Q_store(INS.Qq).C - 1;
   704.       ensure_that_Q0_contains_zero(suspect => INS.Qq);
   705.    end auto_increment;
   706.
   707.    function shift_count return CPU.signed_Q_part;
   708.    pragma Inline(shift_count);
   709.
   710.    function shift_count return CPU.signed_Q_part is
   711.       constant_flag : constant := 1;  -- D15 of order = 1 => fixed amount
   712.    begin
   713.       if (INS.order.syllable_1 and constant_flag) /= 0  then
   714.          return resign(KDF9.Q_part(INS.order.syllable_1/2 xor 64)) - 64;
   715.       else
   716.          return resign((the_Q_store(INS.Qq).C and 255) xor 128) - 128;
   717.       end if;
   718.    end shift_count;
   719.
   720.    procedure do_a_two_syllable_order is
   721.       A  : KDF9.word;
   722.       AB : KDF9.pair;
   723.       CD : KDF9.pair;
   724.    begin
   725.       case INS.syndrome is
   726.
   727.          when JCqNZS =>
   728.             if the_Q_store(INS.Qq).C /= 0 then
   729.                if fetching_normally then
   730.                   set_IWB0_and_IWB1_for_a_JCqNZS_loop;
   731.                   the_CPU_delta := the_CPU_delta + 7;  -- Takes 11µs the first time it jumps.
   732.                end if;
   733.                -- The IWBs now contain the loop, so go to syllable 0 of IWB0.
   734.                go_back_to_the_start_of_IWB0;
   735.             else
   736.                continue_after_JCqNZS;
   737.             end if;
   738.             the_CPU_delta := the_CPU_delta + 4;
   739.
   740.          when MkMq =>
   741.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M, the_Q_store(INS.Qq).M);
   742.             validate_access(the_trace_address);
   743.             ensure_that_the_nest_has_room_for_a_result;
   744.             the_trace_operand := fetch_word(the_trace_address);
   745.             push(the_trace_operand);
   746.             the_CPU_delta := the_CPU_delta + 7;
   747.
   748.          when MkMqQ =>
   749.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M, the_Q_store(INS.Qq).M);
   750.             validate_access(the_trace_address);
   751.             ensure_that_the_nest_has_room_for_a_result;
   752.             the_trace_operand := fetch_word(the_trace_address);
   753.             push(the_trace_operand);
   754.             auto_increment;
   755.             the_CPU_delta := the_CPU_delta + 8;
   756.
   757.          when MkMqH =>
   758.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M, the_Q_store(INS.Qq).M/2);
   759.             validate_access(the_trace_address);
   760.             the_trace_operand := fetch_halfword(the_trace_address, the_Q_store(INS.Qq).M mod 2);
   761.             ensure_that_the_nest_has_room_for_a_result;
   762.             push(the_trace_operand);
   763.             the_CPU_delta := the_CPU_delta + 7;
   764.
   765.          when MkMqQH =>
   766.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M, the_Q_store(INS.Qq).M/2);
   767.             validate_access(the_trace_address);
   768.             the_trace_operand := fetch_halfword(the_trace_address, the_Q_store(INS.Qq).M mod 2);
   769.             ensure_that_the_nest_has_room_for_a_result;
   770.             push(the_trace_operand);
   771.             auto_increment;
   772.             the_CPU_delta := the_CPU_delta + 8;
   773.
   774.          when MkMqN =>
   775.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M+1, the_Q_store(INS.Qq).M);
   776.             validate_access(the_trace_address);
   777.             ensure_that_the_nest_has_room_for_a_result;
   778.             the_trace_operand := fetch_word(the_trace_address);
   779.             push(the_trace_operand);
   780.             the_CPU_delta := the_CPU_delta + 7;
   781.
   782.          when MkMqQN =>
   783.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M+1, the_Q_store(INS.Qq).M);
   784.             validate_access(the_trace_address);
   785.             ensure_that_the_nest_has_room_for_a_result;
   786.             the_trace_operand := fetch_word(the_trace_address);
   787.             push(the_trace_operand);
   788.             auto_increment;
   789.             the_CPU_delta := the_CPU_delta + 8;
   790.
   791.          when MkMqHN =>
   792.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M+1, the_Q_store(INS.Qq).M/2);
   793.             validate_access(the_trace_address);
   794.             the_trace_operand := fetch_halfword(the_trace_address, the_Q_store(INS.Qq).M mod 2);
   795.             ensure_that_the_nest_has_room_for_a_result;
   796.             push(the_trace_operand);
   797.             the_CPU_delta := the_CPU_delta + 7;
   798.
   799.          when MkMqQHN =>
   800.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M+1, the_Q_store(INS.Qq).M/2);
   801.             validate_access(the_trace_address);
   802.             the_trace_operand := fetch_halfword(the_trace_address, the_Q_store(INS.Qq).M mod 2);
   803.             ensure_that_the_nest_has_room_for_a_result;
   804.             push(the_trace_operand);
   805.             auto_increment;
   806.             the_CPU_delta := the_CPU_delta + 8;
   807.
   808.          when TO_MkMq =>
   809.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M, the_Q_store(INS.Qq).M);
   810.             validate_access(the_trace_address);
   811.             ensure_that_the_nest_holds_an_operand;
   812.             the_trace_operand := pop;
   813.             store_word(the_trace_operand, the_trace_address);
   814.             the_CPU_delta := the_CPU_delta + 7;
   815.
   816.          when TO_MkMqQ =>
   817.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M, the_Q_store(INS.Qq).M);
   818.             validate_access(the_trace_address);
   819.             ensure_that_the_nest_holds_an_operand;
   820.             the_trace_operand := pop;
   821.             store_word(the_trace_operand, the_trace_address);
   822.             auto_increment;
   823.             the_CPU_delta := the_CPU_delta + 8;
   824.
   825.          when TO_MkMqH =>
   826.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M, the_Q_store(INS.Qq).M/2);
   827.             validate_access(the_trace_address);
   828.             ensure_that_the_nest_holds_an_operand;
   829.             the_trace_operand := pop;
   830.             store_halfword(the_trace_operand, the_trace_address, the_Q_store(INS.Qq).M mod 2);
   831.             the_CPU_delta := the_CPU_delta + 7;
   832.
   833.          when TO_MkMqQH =>
   834.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M, the_Q_store(INS.Qq).M/2);
   835.             validate_access(the_trace_address);
   836.             ensure_that_the_nest_holds_an_operand;
   837.             the_trace_operand := pop;
   838.             store_halfword(the_trace_operand, the_trace_address, the_Q_store(INS.Qq).M mod 2);
   839.             auto_increment;
   840.             the_CPU_delta := the_CPU_delta + 8;
   841.
   842.          when TO_MkMqN =>
   843.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M+1, the_Q_store(INS.Qq).M);
   844.             validate_access(the_trace_address);
   845.             ensure_that_the_nest_holds_an_operand;
   846.             the_trace_operand := pop;
   847.             store_word(the_trace_operand, the_trace_address);
   848.             the_CPU_delta := the_CPU_delta + 7;
   849.
   850.          when TO_MkMqQN =>
   851.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M+1, the_Q_store(INS.Qq).M);
   852.             validate_access(the_trace_address);
   853.             ensure_that_the_nest_holds_an_operand;
   854.             the_trace_operand := pop;
   855.             store_word(the_trace_operand, the_trace_address);
   856.             auto_increment;
   857.             the_CPU_delta := the_CPU_delta + 8;
   858.
   859.          when TO_MkMqHN =>
   860.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M+1, the_Q_store(INS.Qq).M);
   861.             validate_access(the_trace_address);
   862.             ensure_that_the_nest_holds_an_operand;
   863.             the_trace_operand := pop;
   864.             store_halfword(the_trace_operand, the_trace_address, the_Q_store(INS.Qq).M mod 2);
   865.             the_CPU_delta := the_CPU_delta + 7;
   866.
   867.          when TO_MkMqQHN =>
   868.             the_trace_address := validated_sum(the_Q_store(INS.Qk).M+1, the_Q_store(INS.Qq).M);
   869.             validate_access(the_trace_address);
   870.             ensure_that_the_nest_holds_an_operand;
   871.             the_trace_operand := pop;
   872.             store_halfword(the_trace_operand, the_trace_address, the_Q_store(INS.Qq).M mod 2);
   873.             auto_increment;
   874.             the_CPU_delta := the_CPU_delta + 8;
   875.
   876.          when M_PLUS_Iq =>
   877.             the_CPU_delta := the_CPU_delta + 4;
   878.             the_Q_store(INS.Qq).M := the_Q_store(INS.Qq).M + the_Q_store(INS.Qq).I;
   879.
   880.          when M_MINUS_Iq =>
   881.             the_CPU_delta := the_CPU_delta + 5;
   882.             the_Q_store(INS.Qq).M := the_Q_store(INS.Qq).M - the_Q_store(INS.Qq).I;
   883.
   884.          when NCq =>
   885.             the_CPU_delta := the_CPU_delta + 5;
   886.             the_Q_store(INS.Qq).C := - the_Q_store(INS.Qq).C;
   887.
   888.          when DCq =>
   889.             the_CPU_delta := the_CPU_delta + 3;
   890.             the_Q_store(INS.Qq).C := the_Q_store(INS.Qq).C - 1;
   891.             ensure_that_Q0_contains_zero(suspect => INS.Qq);
   892.
   893.          when POS1_TO_Iq =>
   894.             the_CPU_delta := the_CPU_delta + 3;
   895.             the_Q_store(INS.Qq).I := + 1;
   896.             ensure_that_Q0_contains_zero(suspect => INS.Qq);
   897.
   898.          when NEG1_TO_Iq =>
   899.             the_CPU_delta := the_CPU_delta + 3;
   900.             the_Q_store(INS.Qq).I := - 1;
   901.             ensure_that_Q0_contains_zero(suspect => INS.Qq);
   902.
   903.          when POS2_TO_Iq =>
   904.             the_CPU_delta := the_CPU_delta + 3;
   905.             the_Q_store(INS.Qq).I := + 2;
   906.             ensure_that_Q0_contains_zero(suspect => INS.Qq);
   907.
   908.          when NEG2_TO_Iq =>
   909.             the_CPU_delta := the_CPU_delta + 3;
   910.             the_Q_store(INS.Qq).I := - 2;
   911.             ensure_that_Q0_contains_zero(suspect => INS.Qq);
   912.
   913.          when CqTOQk =>
   914.             the_CPU_delta := the_CPU_delta + 4;
   915.             the_Q_store(INS.Qk).C := the_Q_store(INS.Qq).C;
   916.             ensure_that_Q0_contains_zero(suspect => INS.Qk);
   917.
   918.          when IqTOQk =>
   919.             the_CPU_delta := the_CPU_delta + 4;
   920.             the_Q_store(INS.Qk).I := the_Q_store(INS.Qq).I;
   921.             ensure_that_Q0_contains_zero(suspect => INS.Qk);
   922.
   923.          when MqTOQk =>
   924.             the_CPU_delta := the_CPU_delta + 4;
   925.             the_Q_store(INS.Qk).M := the_Q_store(INS.Qq).M;
   926.             ensure_that_Q0_contains_zero(suspect => INS.Qk);
   927.
   928.          when QqTOQk =>
   929.             the_CPU_delta := the_CPU_delta + 4;
   930.             the_Q_store(INS.Qk) := the_Q_store(INS.Qq);
   931.             ensure_that_Q0_contains_zero(suspect => INS.Qk);
   932.
   933.          when CIqTOQk =>
   934.             the_CPU_delta := the_CPU_delta + 4;
   935.             the_Q_store(INS.Qk).C := the_Q_store(INS.Qq).C;
   936.             the_Q_store(INS.Qk).I := the_Q_store(INS.Qq).I;
   937.             ensure_that_Q0_contains_zero(suspect => INS.Qk);
   938.
   939.          when IMqTOQk =>
   940.             the_CPU_delta := the_CPU_delta + 4;
   941.             the_Q_store(INS.Qk).I := the_Q_store(INS.Qq).I;
   942.             the_Q_store(INS.Qk).M := the_Q_store(INS.Qq).M;
   943.             ensure_that_Q0_contains_zero(suspect => INS.Qk);
   944.
   945.          when CMqTOQk =>
   946.             the_CPU_delta := the_CPU_delta + 4;
   947.             the_Q_store(INS.Qk).C := the_Q_store(INS.Qq).C;
   948.             the_Q_store(INS.Qk).M := the_Q_store(INS.Qq).M;
   949.             ensure_that_Q0_contains_zero(suspect => INS.Qk);
   950.
   951.          when QCIMq =>
   952.             ensure_that_the_nest_has_room_for_a_result;
   953.             if (INS.Qk and all_Q_choice) = all_Q_choice then -- Qq
   954.                push(as_word(the_Q_store(INS.Qq)));
   955.                the_CPU_delta := the_CPU_delta + 4;
   956.             elsif (INS.Qk and M_part_choice) /= 0 then       -- Mq
   957.                push(sign_extended(the_Q_store(INS.Qq).M));
   958.                the_CPU_delta := the_CPU_delta + 4;
   959.             elsif (INS.Qk and C_part_choice) /= 0 then       -- Cq
   960.                push(sign_extended(the_Q_store(INS.Qq).C));
   961.                the_CPU_delta := the_CPU_delta + 5;
   962.             elsif (INS.Qk and I_part_choice) /= 0 then       -- Iq
   963.                push(sign_extended(the_Q_store(INS.Qq).I));
   964.                the_CPU_delta := the_CPU_delta + 6;
   965.             else
   966.                trap_invalid_instruction;
   967.             end if;
   968.
   969.          when TO_RCIMq =>
   970.             ensure_that_the_nest_holds_an_operand;
   971.             if (INS.Qk and all_Q_choice) = all_Q_choice then -- =Qq
   972.                the_Q_store(INS.Qq) := as_Q(pop);
   973.                the_CPU_delta := the_CPU_delta + 2;
   974.             elsif (INS.Qk and M_part_choice) /= 0 then       -- =[R]Mq
   975.                the_Q_store(INS.Qq).M := KDF9.Q_part(pop and Q_part_mask);
   976.                if (INS.Qk and reset_choice) /= 0 then
   977.                   the_Q_store(INS.Qq).C := 0;
   978.                   the_Q_store(INS.Qq).I := 1;
   979.                   the_CPU_delta := the_CPU_delta + 3;
   980.                else
   981.                   the_CPU_delta := the_CPU_delta + 2;
   982.                end if;
   983.             elsif (INS.Qk and C_part_choice) /= 0 then       -- =[R]Cq
   984.                the_Q_store(INS.Qq).C := KDF9.Q_part(pop and Q_part_mask);
   985.                if (INS.Qk and reset_choice) /= 0 then
   986.                   the_Q_store(INS.Qq).I := 1;
   987.                   the_Q_store(INS.Qq).M := 0;
   988.                   the_CPU_delta := the_CPU_delta + 3;
   989.                else
   990.                   the_CPU_delta := the_CPU_delta + 2;
   991.                end if;
   992.             elsif (INS.Qk and I_part_choice) /= 0 then       -- =[R]Iq
   993.                the_Q_store(INS.Qq).I := KDF9.Q_part(pop and Q_part_mask);
   994.                if (INS.Qk and reset_choice) /= 0 then
   995.                   the_Q_store(INS.Qq).C := 0;
   996.                   the_Q_store(INS.Qq).M := 0;
   997.                   the_CPU_delta := the_CPU_delta + 3;
   998.                else
   999.                   the_CPU_delta := the_CPU_delta + 2;
  1000.                end if;
  1001.             else
  1002.                trap_invalid_instruction;
  1003.             end if;
  1004.             ensure_that_Q0_contains_zero(suspect => INS.Qq);
  1005.
  1006.          when ADD_TO_QCIMq =>
  1007.             ensure_that_the_nest_has_room_for_a_result;
  1008.             ensure_that_the_nest_holds_an_operand;
  1009.             if (INS.Qk and all_Q_choice) = all_Q_choice then -- =+Qq
  1010.                the_Q_store(INS.Qq) := as_Q(as_word(the_Q_store(INS.Qq)) + pop);
  1011.                the_CPU_delta := the_CPU_delta + 5;
  1012.             elsif (INS.Qk and M_part_choice) /= 0 then       -- =+Mq
  1013.                the_Q_store(INS.Qq).M := KDF9.Q_part(Q_part_mask and
  1014.                                              (sign_extended(the_Q_store(INS.Qq).M) + pop));
  1015.                the_CPU_delta := the_CPU_delta + 5;
  1016.             elsif (INS.Qk and C_part_choice) /= 0 then       -- =+Cq
  1017.                the_Q_store(INS.Qq).C := KDF9.Q_part(Q_part_mask and
  1018.                                              (sign_extended(the_Q_store(INS.Qq).C) + pop));
  1019.                the_CPU_delta := the_CPU_delta + 6;
  1020.             elsif (INS.Qk and I_part_choice) /= 0 then       -- =+Iq
  1021.                the_Q_store(INS.Qq).I := KDF9.Q_part(Q_part_mask and
  1022.                                              (sign_extended(the_Q_store(INS.Qq).I) + pop));
  1023.                the_CPU_delta := the_CPU_delta + 7;
  1024.             else
  1025.                trap_invalid_instruction;
  1026.             end if;
  1027.             ensure_that_Q0_contains_zero(suspect => INS.Qq);
  1028.
  1029.          when SHA =>
  1030.             check_whether_the_nest_holds_an_operand;
  1031.             A := read_top;
  1032.             write_top(KDF9.word'(shift_arithmetic(A, shift_count)));
  1033.             the_CPU_delta := the_CPU_delta + 2 + shift_time(Natural(abs shift_count));
  1034.
  1035.          when SHAD =>
  1036.             check_whether_the_nest_holds_2_operands;
  1037.             AB := read_top;
  1038.             write_top(KDF9.pair'(shift_arithmetic(AB, shift_count)));
  1039.             the_CPU_delta := the_CPU_delta + 2 + shift_time(Natural(abs shift_count));
  1040.
  1041.          when MACC =>
  1042.             ensure_that_the_nest_holds(at_least => 4);
  1043.             AB := pop;
  1044.             AB := AB.msw * AB.lsw;
  1045.             CD := read_top;
  1046.             write_top(CD + shift_arithmetic(AB, shift_count));
  1047.             the_CPU_delta := the_CPU_delta + 15 + shift_time(Natural(abs shift_count));
  1048.
  1049.          when SHL =>
  1050.             check_whether_the_nest_holds_an_operand;
  1051.             write_top(KDF9.word'(shift_logical(read_top, shift_count)));
  1052.             the_CPU_delta := the_CPU_delta + 2 + shift_time(Natural(abs shift_count));
  1053.
  1054.          when SHLD =>
  1055.             check_whether_the_nest_holds_2_operands;
  1056.             write_top(KDF9.pair'(shift_logical(read_top, shift_count)));
  1057.             the_CPU_delta := the_CPU_delta + 2 + shift_time(Natural(abs shift_count));
  1058.
  1059.          when SHC =>
  1060.             check_whether_the_nest_holds_an_operand;
  1061.             write_top(shift_circular(read_top, shift_count));
  1062.             the_CPU_delta := the_CPU_delta + 3 + shift_time(Natural(abs shift_count));
  1063.
  1064.          when TO_Kk =>
  1065.             LIV_if_user_mode;
  1066.             ensure_that_the_nest_holds_an_operand;
  1067.             case INS.Qq is
  1068.                when K0 =>
  1069.                   if read_top /= all_zero_bits then
  1070.                      for w in all_zero_bits .. read_top mod 8 loop
  1071.                         POSIX.output_line("HOOT!");
  1072.                      end loop;
  1073.                      delay 10.0;
  1074.                   end if;
  1075.                when K1 =>
  1076.                   set_K1_register(read_top);
  1077.                when K2 =>
  1078.                   set_K2_register(read_top);
  1079.                when K3 =>
  1080.                   set_K3_register(read_top);
  1081.                when others =>
  1082.                   trap_invalid_instruction;
  1083.             end case;
  1084.             the_CPU_delta := the_CPU_delta + 3;
  1085.
  1086.          when Kk =>
  1087.             LIV_if_user_mode;
  1088.             ensure_that_the_nest_has_room_for_a_result;
  1089.             case INS.Qk is
  1090.                when K4 =>
  1091.                   push(get_K4_operand);
  1092.                   the_RFIR := (others => False);
  1093.                when K5 =>
  1094.                   push(get_K5_operand);
  1095.                when K7 =>
  1096.                   push(get_K7_operand);
  1097.                when others =>
  1098.                   trap_invalid_instruction;
  1099.             end case;
  1100.             the_CPU_delta := the_CPU_delta + 3;
  1101.
  1102.          when LINK =>
  1103.             if the_CPU_state = Director_state and the_sjns_depth = 0 then -- clear out JB
  1104.                push(all_zero_bits);
  1105.                the_sjns_depth := 0 - 1;
  1106.             else
  1107.                ensure_that_the_nest_has_room_for_a_result;
  1108.                ensure_that_the_sjns_is_not_empty;
  1109.                push(as_word(KDF9.code_link(KDF9.code_point'(pop))));
  1110.             end if;
  1111.             the_CPU_delta := the_CPU_delta + 4;
  1112.
  1113.          when TO_LINK =>
  1114.             ensure_that_the_sjns_is_not_full;
  1115.             ensure_that_the_nest_holds_an_operand;
  1116.             push(KDF9.code_point(as_link(pop)));
  1117.             the_CPU_delta := the_CPU_delta + 3;
  1118.
  1119.          when others =>
  1120.             do_an_IO_order;
  1121.       end case;
  1122.    end do_a_two_syllable_order;
  1123.
  1124.    procedure do_a_jump_order is
  1125.       RA        : KDF9.code_point;
  1126.       A         : KDF9.word;
  1127.    begin
  1128.       case INS.syndrome is
  1129.
  1130.          when Jr =>
  1131.             set_NIA_to_the_INS_target_address;
  1132.             fetching_normally := True;
  1133.             the_CPU_delta := the_CPU_delta + 8;
  1134.
  1135.          when JSr =>
  1136.             ensure_that_the_sjns_is_not_full;
  1137.             push(CIA);
  1138.             set_NIA_to_the_INS_target_address;
  1139.             fetching_normally := True;
  1140.             the_CPU_delta := the_CPU_delta + 11;
  1141.
  1142.          when JrEQ =>
  1143.             ensure_that_the_nest_holds_2_operands;
  1144.             A := pop;
  1145.             if A = read_top then
  1146.                set_NIA_to_the_INS_target_address;
  1147.                fetching_normally := True;
  1148.                the_CPU_delta := the_CPU_delta + 12;
  1149.             else
  1150.                the_CPU_delta := the_CPU_delta + 5;
  1151.             end if;
  1152.
  1153.          when JrNE =>
  1154.             ensure_that_the_nest_holds_2_operands;
  1155.             A := pop;
  1156.             if A /= read_top then
  1157.                set_NIA_to_the_INS_target_address;
  1158.                fetching_normally := True;
  1159.                the_CPU_delta := the_CPU_delta + 12;
  1160.             else
  1161.                the_CPU_delta := the_CPU_delta + 5;
  1162.             end if;
  1163.
  1164.          when JrGTZ =>
  1165.             ensure_that_the_nest_holds_an_operand;
  1166.             if resign(pop) > 0 then
  1167.                set_NIA_to_the_INS_target_address;
  1168.                fetching_normally := True;
  1169.                the_CPU_delta := the_CPU_delta + 11;
  1170.             else
  1171.                the_CPU_delta := the_CPU_delta + 4;
  1172.             end if;
  1173.
  1174.          when JrLTZ =>
  1175.             ensure_that_the_nest_holds_an_operand;
  1176.             A := pop;
  1177.             if resign(A) < 0 then
  1178.                set_NIA_to_the_INS_target_address;
  1179.                fetching_normally := True;
  1180.                the_CPU_delta := the_CPU_delta + 11;
  1181.             else
  1182.                the_CPU_delta := the_CPU_delta + 4;
  1183.             end if;
  1184.
  1185.          when JrEQZ =>
  1186.             ensure_that_the_nest_holds_an_operand;
  1187.              if pop = all_zero_bits then
  1188.                set_NIA_to_the_INS_target_address;
  1189.                fetching_normally := True;
  1190.                the_CPU_delta := the_CPU_delta + 11;
  1191.             else
  1192.                the_CPU_delta := the_CPU_delta + 4;
  1193.             end if;
  1194.
  1195.          when JrLEZ =>
  1196.             ensure_that_the_nest_holds_an_operand;
  1197.             if resign(pop) <= 0 then
  1198.                set_NIA_to_the_INS_target_address;
  1199.                fetching_normally := True;
  1200.                the_CPU_delta := the_CPU_delta + 11;
  1201.             else
  1202.                the_CPU_delta := the_CPU_delta + 4;
  1203.             end if;
  1204.
  1205.          when JrGEZ =>
  1206.             ensure_that_the_nest_holds_an_operand;
  1207.             if resign(pop) >= 0 then
  1208.                set_NIA_to_the_INS_target_address;
  1209.                fetching_normally := True;
  1210.                the_CPU_delta := the_CPU_delta + 11;
  1211.             else
  1212.                the_CPU_delta := the_CPU_delta + 4;
  1213.             end if;
  1214.
  1215.          when JrNEZ =>
  1216.             ensure_that_the_nest_holds_an_operand;
  1217.             if pop /= all_zero_bits then
  1218.                set_NIA_to_the_INS_target_address;
  1219.                fetching_normally := True;
  1220.                the_CPU_delta := the_CPU_delta + 11;
  1221.             else
  1222.                the_CPU_delta := the_CPU_delta + 4;
  1223.             end if;
  1224.
  1225.          when JrV =>
  1226.             the_trace_operand := the_V_bit;
  1227.             if the_V_bit /= 0 then
  1228.                set_NIA_to_the_INS_target_address;
  1229.                fetching_normally := True;
  1230.                the_CPU_delta := the_CPU_delta + 10;
  1231.             else
  1232.                the_CPU_delta := the_CPU_delta + 3;
  1233.             end if;
  1234.
  1235.          when JrNV =>
  1236.             the_trace_operand := the_V_bit;
  1237.             if the_V_bit = 0 then
  1238.                set_NIA_to_the_INS_target_address;
  1239.                fetching_normally := True;
  1240.                the_CPU_delta := the_CPU_delta + 10;
  1241.             else
  1242.                the_CPU_delta := the_CPU_delta + 3;
  1243.             end if;
  1244.             the_V_bit := 0;
  1245.
  1246.          when JrEN =>
  1247.             the_trace_operand := KDF9.word(the_nest_depth);
  1248.             if the_nest_depth = 0 then
  1249.                set_NIA_to_the_INS_target_address;
  1250.                fetching_normally := True;
  1251.                the_CPU_delta := the_CPU_delta + 10;
  1252.             else
  1253.                the_CPU_delta := the_CPU_delta + 3;
  1254.             end if;
  1255.
  1256.          when JrNEN =>
  1257.             the_trace_operand := KDF9.word(the_nest_depth);
  1258.             if the_nest_depth /= 0 then
  1259.                set_NIA_to_the_INS_target_address;
  1260.                fetching_normally := True;
  1261.                the_CPU_delta := the_CPU_delta + 10;
  1262.             else
  1263.                the_CPU_delta := the_CPU_delta + 3;
  1264.             end if;
  1265.
  1266.          when JrEJ =>
  1267.             the_trace_operand := KDF9.word(the_sjns_depth);
  1268.             if the_sjns_depth = 0 then
  1269.                set_NIA_to_the_INS_target_address;
  1270.                fetching_normally := True;
  1271.                the_CPU_delta := the_CPU_delta + 10;
  1272.             end if;
  1273.             the_CPU_delta := the_CPU_delta + 3;
  1274.
  1275.          when JrNEJ =>
  1276.             the_trace_operand := KDF9.word(the_sjns_depth);
  1277.             if the_sjns_depth /= 0 then
  1278.                set_NIA_to_the_INS_target_address;
  1279.                fetching_normally := True;
  1280.                the_CPU_delta := the_CPU_delta + 10;
  1281.             end if;
  1282.             the_CPU_delta := the_CPU_delta + 3;
  1283.
  1284.          when JrTR =>
  1285.             the_trace_operand := the_T_bit;
  1286.             if the_T_bit /= 0 then
  1287.                set_NIA_to_the_INS_target_address;
  1288.                fetching_normally := True;
  1289.                the_CPU_delta := the_CPU_delta + 10;
  1290.             else
  1291.                the_CPU_delta := the_CPU_delta + 3;
  1292.             end if;
  1293.             the_T_bit := 0;
  1294.
  1295.          when JrNTR =>
  1296.             the_trace_operand := the_T_bit;
  1297.             if the_T_bit = 0 then
  1298.                set_NIA_to_the_INS_target_address;
  1299.                fetching_normally := True;
  1300.                the_CPU_delta := the_CPU_delta + 10;
  1301.             else
  1302.                the_CPU_delta := the_CPU_delta + 3;
  1303.             end if;
  1304.             the_T_bit := 0;
  1305.
  1306.          when EXIT_9 =>
  1307.             ensure_that_the_sjns_is_not_empty;
  1308.             RA := pop;
  1309.             if INS.target.syllable_number = 3 then  -- c.f. decode_a_jump_order.
  1310.                increment_by_3(RA);
  1311.             end if;
  1312.             RA.word_number := RA.word_number+INS.target.word_number;
  1313.             set_NIA_to(RA);
  1314.             fetching_normally := True;
  1315.             the_CPU_delta := the_CPU_delta + 12 + KDF9.microseconds(INS.target.syllable_number mod 2);
  1316.
  1317.          when EXITD =>  -- STUB
  1318.             LIV_if_user_mode;
  1319.             ensure_that_the_sjns_is_not_empty;
  1320.             RA := pop;
  1321.             change_to_user_state_at(RA);
  1322.             fetching_normally := True;
  1323.             the_CPU_delta := the_CPU_delta + 11;
  1324.             raise program_exit;  -- STUB for now
  1325.
  1326.          when JrCqZ =>
  1327.             if the_Q_store(INS.Qq).C = 0 then
  1328.                set_NIA_to_the_INS_target_address;
  1329.                fetching_normally := True;
  1330.                the_CPU_delta := the_CPU_delta + 11;
  1331.             else
  1332.                the_CPU_delta := the_CPU_delta + 4;
  1333.             end if;
  1334.
  1335.          when JrCqNZ =>
  1336.             if the_Q_store(INS.Qq).C /= 0 then
  1337.                set_NIA_to_the_INS_target_address;
  1338.                fetching_normally := True;
  1339.                the_CPU_delta := the_CPU_delta + 11;
  1340.             else
  1341.                the_CPU_delta := the_CPU_delta + 4;
  1342.             end if;
  1343.
  1344.          when OUT_9 =>
  1345.             fetching_normally := True;
  1346.             the_CPU_delta := the_CPU_delta + 13;
  1347.             if the_execution_mode = boot_mode then
  1348.                -- Emulate the hardware behaviour.
  1349.                signal_interrupt(OUT_flag);
  1350.                return;  -- we get here only in Director state, so the OUT does not interrupt.
  1351.             end if;
  1352.             if the_nest_depth = 0 then
  1353.                push(all_zero_bits);
  1354.             end if;
  1355.             A := read_top;
  1356.             -- Emulate a subset of the appropriate Director's API.
  1357.             if A <= 47 then
  1358.                do_a_TSD_OUT(OUT_number => A);
  1359.             elsif A > 99 then
  1360.                do_an_EGDON_OUT(OUT_number => A);
  1361.             else
  1362.                -- Other Directors are not handled yet.
  1363.                trap_invalid_instruction("invalid OUT number");
  1364.             end if;
  1365.
  1366.          when others =>
  1367.             trap_invalid_instruction;
  1368.
  1369.       end case;
  1370.    end do_a_jump_order;
  1371.
  1372.    procedure do_a_data_access_order is
  1373.    begin
  1374.       case (INS.syndrome) is
  1375.          when EaMq =>
  1376.             the_trace_address := validated_sum(the_Q_store(INS.Qq).M, INS.operand);
  1377.             validate_access(the_trace_address);
  1378.             ensure_that_the_nest_has_room_for_a_result;
  1379.             the_trace_operand := fetch_word(the_trace_address);
  1380.             push(the_trace_operand);
  1381.             the_CPU_delta := the_CPU_delta + 6;
  1382.
  1383.          when TO_EaMq =>
  1384.             the_trace_address := validated_sum(the_Q_store(INS.Qq).M, INS.operand);
  1385.             validate_access(the_trace_address);
  1386.             ensure_that_the_nest_holds_an_operand;
  1387.             the_trace_operand := pop;
  1388.             store_word(the_trace_operand, the_trace_address);
  1389.             the_CPU_delta := the_CPU_delta + 6;
  1390.
  1391.          when EaMqQ =>
  1392.             the_trace_address := validated_sum(the_Q_store(INS.Qq).M, INS.operand);
  1393.             validate_access(the_trace_address);
  1394.             ensure_that_the_nest_has_room_for_a_result;
  1395.             the_trace_operand := fetch_word(the_trace_address);
  1396.             push(the_trace_operand);
  1397.             auto_increment;
  1398.             the_CPU_delta := the_CPU_delta + 7;
  1399.
  1400.          when TO_EaMqQ =>
  1401.             the_trace_address := validated_sum(the_Q_store(INS.Qq).M, INS.operand);
  1402.             validate_access(the_trace_address);
  1403.             ensure_that_the_nest_holds_an_operand;
  1404.             the_trace_operand := pop;
  1405.             store_word(the_trace_operand, the_trace_address);
  1406.             auto_increment;
  1407.             the_CPU_delta := the_CPU_delta + 7;
  1408.
  1409.          when SET =>
  1410.             ensure_that_the_nest_has_room_for_a_result;
  1411.             the_trace_operand := sign_extended(INS.operand);
  1412.             push(the_trace_operand);
  1413.             the_CPU_delta := the_CPU_delta + 4;
  1414.
  1415.          when others =>
  1416.             trap_invalid_instruction;
  1417.       end case;
  1418.    end do_a_data_access_order;
  1419.
  1420.    procedure update_the_virtual_clocks;
  1421.    pragma Inline(update_the_virtual_clocks);
  1422.
  1423.    procedure update_the_virtual_clocks is
  1424.    begin
  1425.       the_CPU_time := the_CPU_time + the_CPU_delta;
  1426.       the_elapsed_time := the_elapsed_time + the_CPU_delta;
  1427.       if the_CPU_time > the_elapsed_time then
  1428.          the_elapsed_time := the_CPU_time;
  1429.       end if;
  1430.       ICR := ICR + 1;
  1431.    end update_the_virtual_clocks;
  1432.
  1433.    procedure do_a_fast_time_slice is
  1434.    begin
  1435.       for i in 1 .. time_slice loop
  1436.
  1437.          the_CPU_delta := 0;
  1438.
  1439.          process_syllable_0_of_INS;
  1440.          case INS.kind is
  1441.             when one_syllable_order =>
  1442.                do_a_one_syllable_order;
  1443.             when two_syllable_order =>
  1444.                process_syllable_1_of_INS;
  1445.                do_a_two_syllable_order;
  1446.             when normal_jump_order =>
  1447.                process_syllables_1_and_2_of_a_jump_order;
  1448.                do_a_jump_order;
  1449.             when data_access_order =>
  1450.                process_syllables_1_and_2_of_a_data_access_order;
  1451.                do_a_data_access_order;
  1452.          end case;
  1453.
  1454.          update_the_virtual_clocks;
  1455.
  1456.          if the_elapsed_time > the_next_interrupt_time       and then
  1457.                (INS.syndrome /= EXITD and INS.syndrome /= OUT_9) then
  1458.             act_on_pending_interrupts;
  1459.          end if;
  1460.       end loop;
  1461.
  1462.    exception
  1463.
  1464.       when program_exit =>
  1465.          complete_all_extant_transfers;
  1466.          update_the_virtual_clocks;
  1467.          synchronize_the_real_and_virtual_times;
  1468.          raise;
  1469.
  1470.    end do_a_fast_time_slice;
  1471.
  1472.    procedure do_a_traced_instruction_cycle is
  1473.       use tracing.order_flags;
  1474.
  1475.       procedure finalize_traced_instruction_execution is
  1476.       begin
  1477.          update_the_virtual_clocks;
  1478.          synchronize_the_real_and_virtual_times;
  1479.
  1480.          if ICR in low_count .. high_count            and then
  1481.                NIA_word_number in low_bound .. high_bound then
  1482.             take_note_of(the_trace_operand);
  1483.             if the_signature_is_enabled then
  1484.                update_the_digital_signature;
  1485.             end if;
  1486.             if the_histogram_is_enabled then
  1487.                add_INS_to_the_histogram;
  1488.             end if;
  1489.             if the_external_trace_is_enabled then
  1490.                log_to_external_trace;
  1491.             end if;
  1492.             case INS.kind is
  1493.                when two_syllable_order =>
  1494.                   act_on_any_two_syllable_order_watchpoints;
  1495.                when data_access_order =>
  1496.                   act_on_any_data_access_order_watchpoints;
  1497.                when others =>
  1498.                   null;
  1499.             end case;
  1500.          end if;
  1501.       end finalize_traced_instruction_execution;
  1502.
  1503.    begin
  1504.       the_trace_operand := 0;
  1505.       the_trace_address := 0;
  1506.       the_CPU_delta := 0;
  1507.
  1508.       process_syllable_0_of_INS;
  1509.       case INS.kind is
  1510.          when one_syllable_order =>
  1511.             preview_a_one_syllable_order;
  1512.                do_a_one_syllable_order;
  1513.             look_back_at_a_one_syllable_order;
  1514.          when two_syllable_order =>
  1515.             process_syllable_1_of_INS;
  1516.             preview_a_two_syllable_order;
  1517.                do_a_two_syllable_order;
  1518.             look_back_at_a_two_syllable_order;
  1519.          when normal_jump_order =>
  1520.             process_syllables_1_and_2_of_a_jump_order;
  1521.             preview_a_jump_order;
  1522.                do_a_jump_order;
  1523.             look_back_at_a_jump_order;
  1524.          when data_access_order =>
  1525.             process_syllables_1_and_2_of_a_data_access_order;
  1526.             preview_a_data_access_order;
  1527.                do_a_data_access_order;
  1528.             look_back_at_a_data_access_order;
  1529.       end case;
  1530.
  1531.       finalize_traced_instruction_execution;
  1532.
  1533.       if the_Q_store(0) /= all_zero_Q_store then
  1534.          raise emulation_failure with "Q0 is not zero";
  1535.       end if;
  1536.
  1537.       if the_elapsed_time > the_next_interrupt_time       and then
  1538.             (INS.syndrome /= EXITD and INS.syndrome /= OUT_9) then
  1539.          act_on_pending_interrupts;
  1540.       end if;
  1541.
  1542.       if ICR >= time_limit then
  1543.          raise time_expired;
  1544.       end if;
  1545.
  1546.       if (NIA_word_number/is_a_breakpoint    and then
  1547.              ICR in low_count .. high_count)  or else
  1548.                 the_diagnostic_mode = pause_mode then
  1549.          handle_breakpoint;
  1550.       end if;
  1551.
  1552.    exception
  1553.
  1554.       when program_exit =>
  1555.          case INS.kind is
  1556.             when one_syllable_order =>
  1557.                look_back_at_a_one_syllable_order;
  1558.             when two_syllable_order =>
  1559.                look_back_at_a_two_syllable_order;
  1560.             when normal_jump_order =>
  1561.                look_back_at_a_jump_order;
  1562.             when data_access_order =>
  1563.                look_back_at_a_data_access_order;
  1564.          end case;
  1565.
  1566.          complete_all_extant_transfers;
  1567.          finalize_traced_instruction_execution;
  1568.
  1569.          raise;
  1570.
  1571.    end do_a_traced_instruction_cycle;
  1572.
  1573. end KDF9.microcode;

Compiling: ../Source\kdf9-microcode.ads
Source file time stamp: 2015-06-18 00:56:06
Compiled at: 2015-10-28 18:13:48

     1. -- kdf9-microcode.ads
     2. --
     3. -- KDF9 ISP emulation - CPU microcode routines.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package KDF9.microcode is
    20.
    21.    procedure do_a_fast_time_slice;
    22.
    23.    procedure do_a_traced_instruction_cycle;
    24.
    25. end KDF9.microcode;

 1573 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\kdf9-store.adb
Source file time stamp: 2015-06-18 00:56:04
Compiled at: 2015-10-28 18:13:56

     1. -- kdf9-store.adb
     2. --
     3. -- KDF9 core store operations.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9.CPU;
    20.
    21. use  KDF9.CPU;
    22.
    23. package body KDF9.store is
    24.
    25.    function group (EA : KDF9.Q_part)
    26.    return KDF9.Q_part is
    27.    begin
    28.       return EA / group_size;
    29.    end group;
    30.
    31.    procedure validate_address (EA : in KDF9.address) is
    32.       PA : constant KDF9.Q_part := EA + BA;
    33.    begin
    34.       if EA > NOL then
    35.          trap_invalid_instruction("virtual address > NOL");
    36.       end if;
    37.       if PA > max_address then
    38.          trap_invalid_instruction("physical address > 32K-1");
    39.       end if;
    40.    end validate_address;
    41.
    42.    procedure validate_access (EA : in KDF9.address) is
    43.       PA : constant KDF9.Q_part := EA + BA;
    44.    begin
    45.       validate_address(EA);
    46.       if locked_out(group(PA)) then
    47.          the_locked_out_address := PA;
    48.          if the_CPU_state /= Director_state then
    49.             raise LOV_trap;
    50.          end if;
    51.       end if;
    52.    end validate_access;
    53.
    54.    procedure validate_address_range (EA1, EA2 : in KDF9.address) is
    55.    begin
    56.       validate_address(EA1);
    57.       validate_address(EA2);
    58.       if EA1 > EA2 then
    59.          trap_invalid_instruction("initial address > final address");
    60.       end if;
    61.    end validate_address_range;
    62.
    63.    procedure validate_range_access (EA1, EA2 : in KDF9.address) is
    64.       PA1 : constant KDF9.Q_part := EA1 + BA;
    65.       PA2 : constant KDF9.Q_part := EA2 + BA;
    66.    begin
    67.       validate_address_range (EA1, EA2);
    68.       if test_lockouts(KDF9.Q_register'(0, PA1, PA2)) /= 0 then
    69.          if the_CPU_state /= Director_state then
    70.             raise LOV_trap;
    71.          end if;
    72.       end if;
    73.    end validate_range_access;
    74.
    75.    -- Check that A1+A2 is valid; LIV if it is invalid.
    76.    function validated_sum (A1, A2 : in KDF9.Q_part)
    77.    return KDF9.address is
    78.       W : constant KDF9.word := (KDF9.word(A1) + KDF9.word(A2)) and Q_part_mask;
    79.    begin
    80.       if W > max_address then
    81.          trap_invalid_instruction("virtual address > 32K-1");
    82.       end if;
    83.       return KDF9.address(W);
    84.    end validated_sum;
    85.
    86.    function fetch_symbol (EA : KDF9.Q_part; sn : KDF9.symbol_number)
    87.    return KDF9.symbol is
    88.       place   : constant Natural     := 42 - 6*Natural(sn);
    89.       address : constant KDF9.Q_part := EA + BA;
    90.    begin
    91.       return KDF9.symbol(shift_word_right(core(address), place) and 8#77#);
    92.    end fetch_symbol;
    93.
    94.    procedure store_symbol (value : in KDF9.symbol;
    95.                            EA    : in KDF9.Q_part;
    96.                            sn    : in KDF9.symbol_number) is
    97.       place  : constant Natural   := 42 - 6*Natural(sn);
    98.       mask   : constant KDF9.word := not shift_word_left(8#77#, place);
    99.       symbol : constant KDF9.word := shift_word_left(KDF9.word(value), place);
   100.    begin
   101.       core(EA+BA) := (core(EA+BA) and mask) or symbol;
   102.    end store_symbol;
   103.
   104.    function fetch_syllable (EA : KDF9.code_point)
   105.    return KDF9.syllable is
   106.       place   : constant Natural     := 40 - 8*Natural(EA.syllable_number);
   107.       address : constant KDF9.Q_part := KDF9.Q_part(EA.word_number) + BA;
   108.    begin
   109.       return KDF9.syllable(shift_word_right(core(address), place) and 8#377#);
   110.    end fetch_syllable;
   111.
   112.    procedure store_syllable (value : in KDF9.syllable; EA : in KDF9.code_point) is
   113.       place    : constant Natural      := 40 - 8*Natural(EA.syllable_number);
   114.       address  : constant KDF9.Q_part  := KDF9.Q_part(EA.word_number) + BA;
   115.       syllable : constant KDF9.word := shift_word_left(KDF9.word(value), place);
   116.       mask     : constant KDF9.word := not shift_word_left(8#377#, place);
   117.    begin
   118.       core(address) := (core(address) and mask) or syllable;
   119.    end store_syllable;
   120.
   121.    function fetch_halfword (EA : KDF9.Q_part; hn : KDF9.halfword_number)
   122.    return KDF9.word is
   123.       place   : constant Natural      := 24 - 24*Natural(hn);
   124.       address : constant KDF9.Q_part  := EA + BA;
   125.    begin
   126.       return shift_word_left(shift_word_right(core(address), place), 24);
   127.    end fetch_halfword;
   128.
   129.    procedure store_halfword (value : in KDF9.word;
   130.                              EA    : in KDF9.Q_part;
   131.                              hn    : in KDF9.halfword_number) is
   132.       place   : constant Natural      := 24 - 24*Natural(hn);
   133.       address : constant KDF9.Q_part  := EA + BA;
   134.       half    : constant KDF9.word := shift_word_left(shift_word_right(value, 24), place);
   135.       mask    : constant KDF9.word := not shift_word_left(halfword_mask, place);
   136.    begin
   137.       core(address) := (core(address) and mask) or half;
   138.    end store_halfword;
   139.
   140.    function fetch_word (EA : KDF9.Q_part)
   141.    return KDF9.word is
   142.    begin
   143.       return core(EA+BA);
   144.    end fetch_word;
   145.
   146.    procedure store_word (value : in KDF9.word; EA : in KDF9.Q_part) is
   147.    begin
   148.       core(EA+BA) := value;
   149.    end store_word;
   150.
   151.    function test_lockouts (Q : in KDF9.Q_register)
   152.    return KDF9.word is
   153.       a : KDF9.address;
   154.    begin
   155.       validate_address_range (Q.I, Q.M);
   156.       a := Q.I;
   157.       loop
   158.          if locked_out(group(a)) then
   159.             the_locked_out_address := a;
   160.             return 1;
   161.          end if;
   162.       exit when group_size > Q.M - a;
   163.          a := a + group_size;
   164.       end loop;
   165.       return 0;
   166.    end test_lockouts;
   167.
   168.    procedure set_lockouts (Q : in KDF9.Q_register) is
   169.    begin
   170.       validate_address_range (Q.I, Q.M);
   171.       for g in group(Q.I) .. group(Q.M) loop
   172.          locked_out(g) := True;
   173.       end loop;
   174.    end set_lockouts;
   175.
   176.    procedure clear_lockouts (Q : in KDF9.Q_register) is
   177.    begin
   178.       validate_address_range (Q.I, Q.M);
   179.       for g in group(Q.I) .. group(Q.M) loop
   180.          locked_out(g) := False;
   181.       end loop;
   182.    end clear_lockouts;
   183.
   184.    procedure mirror (start_address, end_address : in KDF9.address) is
   185.       lower_address : KDF9.address := start_address;
   186.       upper_address : KDF9.address := end_address;
   187.       lo_word, hi_word : KDF9.word;
   188.    begin
   189.       while lower_address < upper_address loop
   190.          lo_word := fetch_word(lower_address);
   191.          hi_word := fetch_word(upper_address);
   192.          store_word(hi_word, lower_address);
   193.          store_word(lo_word, upper_address);
   194.          lower_address := lower_address + 1;
   195.          upper_address := upper_address - 1;
   196.       end loop;
   197.    end mirror;
   198.
   199. end KDF9.store;

Compiling: ../Source\kdf9-store.ads
Source file time stamp: 2015-06-18 00:56:04
Compiled at: 2015-10-28 18:13:56

     1. -- kdf9-store.ads
     2. --
     3. -- KDF9 core store operations.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package KDF9.store is
    20.
    21.    function group (EA : KDF9.Q_part)
    22.    return KDF9.Q_part;
    23.    pragma Inline(group);
    24.
    25.    function fetch_symbol (EA : KDF9.Q_part; sn : KDF9.symbol_number)
    26.    return KDF9.symbol;
    27.
    28.    function fetch_syllable (EA : KDF9.code_point)
    29.    return KDF9.syllable;
    30.    pragma Inline(fetch_syllable);
    31.
    32.    function fetch_halfword (EA : KDF9.Q_part; hn : KDF9.halfword_number)
    33.    return KDF9.word;
    34.
    35.    function fetch_word (EA : KDF9.Q_part)
    36.    return KDF9.word;
    37.    pragma Inline(fetch_word);
    38.
    39.    procedure store_symbol (value : in KDF9.symbol;
    40.                            EA    : in KDF9.Q_part;
    41.                            sn    : in KDF9.symbol_number);
    42.
    43.    procedure store_syllable (value : in KDF9.syllable; EA : in KDF9.code_point);
    44.
    45.    procedure store_halfword (value : in KDF9.word;
    46.                              EA    : in KDF9.Q_part;
    47.                              hn    : in KDF9.halfword_number);
    48.
    49.    procedure store_word (value : in KDF9.word; EA : in KDF9.Q_part);
    50.    pragma Inline(store_word);
    51.
    52.    -- Check that A1+A2 is valid; LIV if it is invalid.
    53.    function validated_sum (A1, A2 : in KDF9.Q_part)
    54.    return KDF9.address;
    55.    pragma Inline(validated_sum);
    56.
    57.    -- Check that EA, EA+BA are valid; LIV if invalid.
    58.    procedure validate_address (EA : in KDF9.address);
    59.    pragma Inline(validate_address);
    60.
    61.    -- If a store access is locked out, the offending address is left here,
    62.    --    by test_lockouts or by validate_access.
    63.    the_locked_out_address : KDF9.Q_part;
    64.
    65.    -- Check EA and lockout for EA; deal with LOV if lockout set.
    66.    procedure validate_access (EA : in KDF9.address);
    67.    pragma Inline(validate_access);
    68.
    69.    -- Check that EA1,, EA2, EA1+BA, EA2+BA are valid, and EA1 <= EA2.
    70.    --    LIV in any invalid case.
    71.    procedure validate_address_range (EA1, EA2 : in KDF9.address);
    72.
    73.    -- Check EA1, EA2, and lockouts for EA1 .. EA2.
    74.    procedure validate_range_access (EA1, EA2 : in KDF9.address);
    75.
    76.    function test_lockouts (Q : in KDF9.Q_register)
    77.    return KDF9.word; -- Yields True if any of the designated words are locked out.
    78.
    79.    procedure clear_lockouts (Q : in KDF9.Q_register);
    80.
    81.    procedure set_lockouts (Q : in KDF9.Q_register);
    82.
    83.    -- Reverse the contents of the store area delimited by the given addresses.
    84.    procedure mirror (start_address, end_address : in KDF9.address);
    85.
    86.    -- The group size of 32 words is 1 core allocation/lockout unit.
    87.    group_size : constant := 32;
    88.
    89.    -- The maximum size KDF9 core store has 32Kibiwords.
    90.    max_address   : constant := 2**15 - 1;
    91.
    92. private
    93.
    94.    type word_array is array (KDF9.Q_part range <>) of KDF9.word;
    95.    for  word_array'Component_Size use 64;
    96.    pragma Convention (C, word_array);
    97.
    98.    -- The core store of KDF9.
    99.    core : word_array (KDF9.Q_part range 0 .. max_address) := (others => 0);
   100.
   101.    -- The lockout store has one bit for every group_size words.
   102.    last_lockout : constant := (max_address + group_size) / group_size - 1;
   103.    locked_out   : array (KDF9.Q_part range 0 .. last_lockout) of Boolean := (others => False);
   104.
   105. end KDF9.store;

 199 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\map_ctrl_c_to_flex.adb
Source file time stamp: 2015-06-18 00:55:54
Compiled at: 2015-10-28 18:13:57

     1. -- map_ctrl_c_to_flex.adb
     2. --
     3. -- Handle user's CTRL-C interrupt; convert it to a KDF9 FLEX (TINT) interrupt.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Exceptions;
    20. --
    21. with exceptions;
    22. with HCI;
    23. with KDF9;
    24. with POSIX;
    25. with finalize_ee9;
    26. with settings;
    27. with state_display;
    28.
    29. use  exceptions;
    30. use  HCI;
    31. use  KDF9;
    32. use  settings;
    33. use  state_display;
    34.
    35. procedure map_CTRL_C_to_FLEX is
    36.
    37.    pragma Unsuppress(All_Checks);
    38.
    39. begin
    40.    log_new_line;
    41.    continue_when_GO_is_pressed;
    42.    quit_if_requested;
    43.    if the_execution_mode = boot_mode then
    44.       signal_interrupt(FLEX_flag);
    45.    else
    46.       show_current_state;
    47.    end if;
    48.    flush;
    49. exception
    50.    when quit_request =>
    51.       log_line("Run stopped by user!");
    52.       finalize_ee9;
    53.       POSIX.exit_program(0);
    54.    when error : others =>
    55.       log_ee9_status("Failure in ee9: "
    56.                     & Ada.Exceptions.Exception_Information(error)
    57.                     & " was raised in 'map_CTRL_C_to_FLEX'!");
    58.       finalize_ee9;
    59.       POSIX.exit_program(1);
    60. end map_CTRL_C_to_FLEX;
    61.

Compiling: ../Source\map_ctrl_c_to_flex.ads
Source file time stamp: 2015-06-18 00:55:54
Compiled at: 2015-10-28 18:13:57

     1. -- map_ctrl_c_to_flex.ads
     2. --
     3. -- Handle user's CTRL-C interrupt; convert it to a KDF9 FLEX (TINT) interrupt.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. procedure map_CTRL_C_to_FLEX;

 61 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\state_display.adb
Source file time stamp: 2015-06-18 00:55:40
Compiled at: 2015-10-28 18:13:57

     1. -- state_display.adb
     2. --
     3. -- Provide the comprehensive machine-state display panel KDF9 never had.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Exceptions;
    20. with Ada.Long_Float_Text_IO;
    21. --
    22. with disassembly;
    23. with dumping;
    24. with exceptions;
    25. with FD_layout;
    26. with formatting;
    27. with generic_sets; pragma Elaborate_All(generic_sets);
    28. with HCI;
    29. with IOC;
    30. with KDF9.compressed_opcodes;
    31. with KDF9.CPU;
    32. with KDF9.PHU_store;
    33. with KDF9.store;
    34. with Latin_1;
    35. with logging.file;
    36. with logging.panel;
    37. with settings;
    38. with tracing;
    39.
    40.
    41. use  Ada.Exceptions;
    42. use  Ada.Long_Float_Text_IO;
    43. --
    44. use  disassembly;
    45. use  dumping;
    46. use  exceptions;
    47. use  FD_layout;
    48. use  formatting;
    49. use  HCI;
    50. use  IOC;
    51. use  KDF9.compressed_opcodes;
    52. use  KDF9.CPU;
    53. use  KDF9.PHU_store;
    54. use  KDF9.store;
    55. use  Latin_1;
    56. use  logging.file;
    57. use  logging.panel;
    58. use  settings;
    59. use  tracing;
    60.
    61. package body state_display is
    62.
    63.    pragma Unsuppress(All_Checks);
    64.
    65.    procedure show_Q_register (the_Q_register : in KDF9.Q_register;
    66.                               width          : in Positive := 8;
    67.                               with_FD_C_part : in Boolean  := False) is
    68.       the_buffer : constant KDF9.Q_part := the_Q_register.C mod 2**4;
    69.    begin
    70.       log('Q');
    71.       if with_FD_C_part and the_buffer = FD0_number then
    72.          log(justified(formatted_as_FD_command(the_Q_register), width));
    73.       else
    74.          log(justified("#" & oct_of(the_Q_register.C, width-2), width));
    75.       end if;
    76.       log("/");
    77.       log(justified("#" & oct_of(the_Q_register.I, width-2), width));
    78.       log("/");
    79.       log(justified("#" & oct_of(the_Q_register.M, width-2), width));
    80.    end show_Q_register;
    81.
    82.    procedure show_Q_in_decimal (the_Q_register : in KDF9.Q_register;
    83.                                 width          : in Positive := 7) is
    84.    begin
    85.       log('Q');
    86.       log(justified(CPU.signed_Q_part'Image(resign(the_Q_register.C)), width));
    87.       log("/");
    88.       log(justified(CPU.signed_Q_part'Image(resign(the_Q_register.I)), width));
    89.       log("/");
    90.       log(justified(CPU.signed_Q_part'Image(resign(the_Q_register.M)), width));
    91.    end show_Q_in_decimal;
    92.
    93.    procedure show_in_syllables_form (the_word : in KDF9.word) is
    94.       word : KDF9.word := the_word;
    95.       syllable : KDF9.syllable;
    96.    begin
    97.       for b in 0 .. 5 loop
    98.          word := rotate_word_left(word, 8);
    99.          syllable := KDF9.syllable(word and 8#377#);
   100.          log("#");
   101.          log(justified(oct_of(syllable), 3));
   102.          log(" ");
   103.       end loop;
   104.    end show_in_syllables_form;
   105.
   106.    function glyph_for (char : Character)
   107.    return Character is
   108.    begin
   109.       if char = LF then
   110.          return '®';
   111.       elsif char = FF then
   112.          return '©';
   113.       elsif char = HT then
   114.          return '¬';
   115.       elsif char = SUB then
   116.          return KDF9.W_F;
   117.       else
   118.          return char;
   119.       end if;
   120.    end glyph_for;
   121.
   122.    procedure show_in_LP_form (the_word : in KDF9.word) is
   123.       word : KDF9.word := the_word;
   124.       data : String(1 .. 8);
   125.    begin
   126.       for b in reverse data'Range loop
   127.          data(b) := glyph_for(to_LP(KDF9.symbol(word and 8#77#)));
   128.          word := shift_logical(word, -6);
   129.       end loop;
   130.       log(data);
   131.    end show_in_LP_form;
   132.
   133.   procedure show_in_various_formats (the_word : in KDF9.word;
   134.                                       column   : in Positive := 5) is
   135.       image : String(1 .. 18);
   136.    begin
   137.       log_octal(the_word);
   138.       log(" = ");
   139.       log(justified(trimmed(CPU.signed'Image(resign(the_word))), 16));
   140.       log(" = ");
   141.       Put(image, host_float(CPU.float(the_word)), Aft => 11, Exp => 2);
   142.       log(trimmed(image));
   143.       log_new_line;
   144.       tab_log_to(column);
   145.       log(" = ");
   146.       show_Q_register(as_Q(the_word));
   147.       log("   = ");
   148.       show_Q_in_decimal(as_Q(the_word));
   149.       log_new_line;
   150.       tab_log_to(column);
   151.       log(" = ");
   152.       show_in_syllables_form(the_word);
   153.       log("= """);
   154.       show_in_LP_form(the_word);
   155.       log("""");
   156.    end show_in_various_formats;
   157.
   158.    procedure show_progress is
   159.    begin
   160.       log("ORDERS:     ");
   161.       log(justified(KDF9.order_counter'Image(ICR), 10));
   162.       log_line(" executed (ICR)");
   163.       log("CPU TIME:   ");
   164.       log(justified(KDF9.microseconds'Image(the_CPU_time), 10));
   165.       log_line(" KDF9 us. (RAN)");
   166.       log("CLOCK TIME: ");
   167.       log(justified(KDF9.microseconds'Image(the_clock_time), 10));
   168.       log_line(" KDF9 us. (EL)");
   169.    end show_progress;
   170.
   171.    procedure show_Director_registers is
   172.    begin
   173.       log("The CPU is in ");
   174.       log_line(KDF9.CPU_state'Image(the_CPU_state));
   175.       log("CONTEXT:  ");
   176.       log_line(justified(KDF9.context'Image(the_context), 1));
   177.       log("PRIORITY: ");
   178.       log_line(justified(KDF9.priority'Image(CPL), 1));
   179.       log("BA:       ");
   180.       log_line(justified("#" & oct_of(BA), 6));
   181.       log("NOL:      ");
   182.       log_line(justified("#" & oct_of(NOL), 6));
   183.       log("CPDAR:    ");
   184.       for i in KDF9.buffer_number loop
   185.          if the_CPDAR(i) = 1 then log("A"); else log("U"); end if;
   186.       end loop;
   187.       log_new_line;
   188.       log_line("PHU stores:");
   189.       for p in KDF9.priority loop
   190.          log("CPL" & KDF9.priority'Image(p) & " is ");
   191.          if PHU(p).is_held_up then
   192.             if PHU(p).blockage.reason = buffer_busy then
   193.                log("waiting for ");
   194.                log(logical_device_name_of(IOC.device_number(PHU(p).blockage.buffer_nr)));
   195.                log(" on buffer #");
   196.                log(oct_of(PHU(p).blockage.buffer_nr, 2));
   197.                if PHU(p).blockage.INTQq_wait = 1 then
   198.                   log(", because of INTQq");
   199.                end if;
   200.             else
   201.                log("locked out at");
   202.                log(KDF9.PHU_store.group_address'Image(PHU(p).blockage.group_nr));
   203.             end if;
   204.          else
   205.             log("idle");
   206.          end if;
   207.          log_new_line;
   208.       end loop;
   209.       log_line("RFIR (Interrupt Flags):");
   210.       log("PR:       ");
   211.       log_line(Boolean'Image(the_RFIR(PR_flag)));
   212.       log("FLEX:     ");
   213.       log_line(Boolean'Image(the_RFIR(FLEX_flag)));
   214.       log("LIV:      ");
   215.       log_line( Boolean'Image(the_RFIR(LIV_flag)));
   216.       log("NOUV:     ");
   217.       log_line( Boolean'Image(the_RFIR(NOUV_flag)));
   218.       log("EDT:      ");
   219.       log_line(Boolean'Image(the_RFIR(EDT_flag)));
   220.       log("OUT:      ");
   221.       log_line( Boolean'Image(the_RFIR(OUT_flag)));
   222.       log("LOV:      ");
   223.       log_line( Boolean'Image(the_RFIR(LOV_flag)));
   224.       log("RESET:    ");
   225.       log_line(Boolean'Image(the_RFIR(RESET_flag)));
   226.    end show_Director_registers;
   227.
   228.    procedure show_V_and_T is
   229.    begin
   230.       if the_V_bit/= 0 or the_T_bit /= 0 then
   231.          log_new_line;
   232.          if the_V_bit /= 0 then
   233.             log("V is set. ");
   234.          else
   235.             log("V is clear. ");
   236.          end if;
   237.          if the_T_bit /= 0 then
   238.             log("T is set. ");
   239.          else
   240.             log("T is clear. ");
   241.          end if;
   242.       end if;
   243.    end show_V_and_T;
   244.
   245.    procedure show_nest is
   246.    begin
   247.       if the_nest_depth = 0 then
   248.          log_line("The NEST is empty.");
   249.       else
   250.          log_line("NEST:");
   251.          for i in reverse KDF9.nest_depth loop
   252.             if i < the_nest_depth then
   253.                log(justified("N" & trimmed(KDF9.nest_depth'Image(the_nest_depth-i)), 3) & ": ");
   254.                log_new_line;
   255.                show_in_various_formats(the_nest(i));
   256.                log_new_line;
   257.             end if;
   258.          end loop;
   259.       end if;
   260.    end show_nest;
   261.
   262.    procedure show_sjns is
   263.    begin
   264.       if the_sjns_depth = 0 then
   265.          log_line("The SJNS is empty.");
   266.       else
   267.          log_line("SJNS:");
   268.       end if;
   269.       for i in reverse KDF9.sjns_depth loop
   270.          if i < the_sjns_depth then
   271.             log(justified("S" & trimmed(KDF9.sjns_depth'Image(the_sjns_depth-i)), 3) & ": ");
   272.             log_line(oct_of(the_sjns(i)) & " (" & dec_of(KDF9.code_point(the_sjns(i))) & ")");
   273.          end if;
   274.       end loop;
   275.    end show_sjns;
   276.
   277.    procedure show_Q_store is
   278.       Q_bits  : KDF9.word := 0;
   279.    begin
   280.       for i in KDF9.Q_store'Range loop
   281.          Q_bits := Q_bits or as_word(the_Q_store(i));
   282.       end loop;
   283.       if Q_bits = 0 then
   284.          log_line("Q store: all zero");
   285.          return;
   286.       else
   287.          log_line("Q store:");
   288.       end if;
   289.       for i in KDF9.Q_store'Range loop
   290.          if as_word(the_Q_store(i)) /= KDF9.word'(0) then
   291.             log(justified("Q" & trimmed(KDF9.Q_number'Image(i)), 3) & ": ");
   292.             show_Q_register(the_Q_store(i));
   293.             log("  = ");
   294.             show_Q_in_decimal(the_Q_store(i));
   295.             log_new_line;
   296.          end if;
   297.       end loop;
   298.    end show_Q_store;
   299.
   300.    procedure show_registers is
   301.    begin
   302.       show_progress;
   303.       log_new_line;
   304.       if the_CPU_state = Director_state then
   305.          show_Director_registers;
   306.          log_new_line;
   307.       end if;
   308.       show_sjns;
   309.       log_new_line;
   310.       show_Q_store;
   311.       show_V_and_T;
   312.       log_new_line;
   313.       show_nest;
   314.    end show_registers;
   315.
   316.    procedure show_order is
   317.    begin
   318.       log(machine_code(INS));
   319.       log(", i.e. ");
   320.       log(the_name_of(INS));
   321.    end show_order;
   322.
   323.    procedure show_execution_context is
   324.    begin
   325.       log("At ");
   326.       log(oct_of(CIA));
   327.       log(" (");
   328.       log(dec_of(CIA));
   329.       log(")");
   330.       log("; ICR =");
   331.       log(KDF9.order_counter'Image(ICR));
   332.       log("; the instruction was ");
   333.       show_order;
   334.       log_new_line;
   335.    end show_execution_context;
   336.
   337.    procedure log_to_external_trace is
   338.    begin
   339.       log(the_external_trace_file, oct_of(CIA));
   340.       tab_log_to(the_external_trace_file, 10);
   341.       log(the_external_trace_file, KDF9.order_counter'Image(ICR));
   342.       tab_log_to(the_external_trace_file, 20);
   343.       if only_signature_tracing then
   344.          log(the_external_trace_file, "#");
   345.          log(the_external_trace_file, oct_of(the_digital_signature));
   346.          if the_V_bit /= 0 then
   347.             log(the_external_trace_file, "V");
   348.          else
   349.             log(the_external_trace_file, " ");
   350.          end if;
   351.          if the_nest_depth > 0 then
   352.             log(the_external_trace_file, "#");
   353.             log(the_external_trace_file, oct_of(read_top));
   354.          end if;
   355.       else
   356.          log(the_external_trace_file, KDF9.microseconds'Image(the_CPU_time));
   357.          tab_log_to(the_external_trace_file, 40);
   358.          log(the_external_trace_file, KDF9.nest_depth'Image(the_nest_depth));
   359.          tab_log_to(the_external_trace_file, 43);
   360.          log(the_external_trace_file, KDF9.sjns_depth'Image(the_sjns_depth));
   361.          tab_log_to(the_external_trace_file, 46);
   362.          if the_V_bit /= 0 then
   363.             log(the_external_trace_file, "V");
   364.          else
   365.             log(the_external_trace_file, " ");
   366.          end if;
   367.          if the_T_bit /= 0 then
   368.             log(the_external_trace_file, "T ");
   369.          else
   370.             log(the_external_trace_file, "  ");
   371.          end if;
   372.          tab_log_to(the_external_trace_file, 50);
   373.          if the_nest_depth > 0 then
   374.             log(the_external_trace_file, "#");
   375.             log(the_external_trace_file, oct_of(read_top));
   376.          end if;
   377.          tab_log_to(the_external_trace_file, 68);
   378.       end if;
   379.       log(the_external_trace_file, " |");
   380.       log(the_external_trace_file, the_name_of(INS));
   381.       log_new_line(the_external_trace_file);
   382.    end log_to_external_trace;
   383.
   384.    procedure log_an_external_trace_header is
   385.    begin
   386.       log(the_external_trace_file, "LOCATION");
   387.       tab_log_to(the_external_trace_file, 11);
   388.       log(the_external_trace_file, "ICR");
   389.       tab_log_to(the_external_trace_file, 20);
   390.       if only_signature_tracing then
   391.          log(the_external_trace_file, "DIGITAL SIGNATURE");
   392.       else
   393.          log(the_external_trace_file, " CPU");
   394.          tab_log_to(the_external_trace_file, 40);
   395.          log(the_external_trace_file, "ND");
   396.          tab_log_to(the_external_trace_file, 43);
   397.          log(the_external_trace_file, "SD");
   398.          tab_log_to(the_external_trace_file, 46);
   399.          log(the_external_trace_file, "VT");
   400.          tab_log_to(the_external_trace_file, 50);
   401.          log(the_external_trace_file, "[N1]");
   402.          tab_log_to(the_external_trace_file, 68);
   403.       end if;
   404.       log(the_external_trace_file, " |INSTRUCTION");
   405.       log_new_line(the_external_trace_file);
   406.    end log_an_external_trace_header;
   407.
   408.    procedure show_CIA_and_NIA is
   409.    begin
   410.       log("CIA:        ");
   411.       log_line(justified(oct_of(CIA), 10) & " (" & justified(dec_of(CIA) & ")"));
   412.       log("NIA:        ");
   413.       log_line(justified(oct_of(NIA), 10) & " (" & justified(dec_of(NIA) & ")"));
   414.    end show_CIA_and_NIA;
   415.
   416.    procedure long_witness is
   417.    begin
   418.       log_new_line;
   419.       show_execution_context;
   420.       show_CIA_and_NIA;
   421.       show_registers;
   422.    end long_witness;
   423.
   424.    procedure short_witness is
   425.    begin
   426.       log_new_line;
   427.       show_execution_context;
   428.       if the_sjns_depth > 0 then
   429.          log(" S1: ");
   430.          log(oct_of(the_sjns(the_sjns_depth-1)));
   431.          log("; SJNS depth: ");
   432.          log(justified(KDF9.sjns_depth'Image(the_sjns_depth), 3));
   433.          log_new_line;
   434.       end if;
   435.       if INS.Qq /= 0 then
   436.          log(justified("Q" & trimmed(KDF9.Q_number'Image(INS.Qq)), 3) & ": ");
   437.          show_Q_register(the_Q_store(INS.Qq));
   438.          log_new_line;
   439.       end if;
   440.       if this_op_uses_2_Q_stores(INS.syndrome) and (INS.Qq /= INS.Qk) and (INS.Qk /= 0) then
   441.          log(justified("Q" & trimmed(KDF9.Q_number'Image(INS.Qk)), 3) & ": ");
   442.          show_Q_register(the_Q_store(INS.Qk));
   443.          log_new_line;
   444.       end if;
   445.       show_V_and_T;
   446.       show_nest;
   447.    end short_witness;
   448.
   449.    procedure show_histogram is
   450.
   451.       function summed_counts (from, to : KDF9.syllable)
   452.       return KDF9.order_counter is
   453.          sum : KDF9.order_counter := 0;
   454.       begin
   455.          for i in from .. to loop
   456.             sum := sum + the_histogram(i);
   457.          end loop;
   458.          return sum;
   459.       end summed_counts;
   460.
   461.       total : KDF9.order_counter;
   462.
   463.       procedure log_bin (bin    : in KDF9.syllable;
   464.                          sum    : in KDF9.order_counter;
   465.                          bound  : in Long_Float := 0.0;
   466.                          barred : in Boolean := True) is
   467.          percent : Long_Float;
   468.          image   : String(1 .. 6);
   469.       begin
   470.          if sum /= 0 then
   471.             percent := Long_Float(sum)/Long_Float(total)*100.0;
   472.             if percent < bound then
   473.                return;
   474.             end if;
   475.             log(oct_of(bin) & ": ");
   476.             log(the_skeleton_order(bin));
   477.             tab_log_to(30);
   478.             log(KDF9.order_counter'Image(sum));
   479.             tab_log_to(40);
   480.             Put(image, percent, Aft => 2, Exp => 0);
   481.             log(image & "%");
   482.             if barred then
   483.                log(" |");
   484.                for i in 1 .. Integer(percent) loop
   485.                   log("#");
   486.                end loop;
   487.             end if;
   488.             log_new_line;
   489.          end if;
   490.       end log_bin;
   491.
   492.       procedure log_histogram (bound          : in Long_Float;
   493.                                with_bar_chart : in Boolean) is
   494.       begin
   495.          for i in KDF9.syllable'(0) .. 8#167# loop
   496.             log_bin(i, the_histogram(i), bound, barred => with_bar_chart);
   497.          end loop;
   498.          for i in KDF9.syllable'(8#170#) .. 8#237# loop
   499.             log_bin(i, the_histogram(i), bound, barred => with_bar_chart);
   500.          end loop;
   501.          log_bin(8#240#, summed_counts(from => 8#240#, to => 8#257#), bound, with_bar_chart);
   502.          log_bin(8#260#, summed_counts(from => 8#240#, to => 8#277#), bound, with_bar_chart);
   503.          for i in KDF9.syllable'(8#300#) .. 8#377# loop
   504.             log_bin(i, the_histogram(i), bound, with_bar_chart);
   505.          end loop;
   506.       end log_histogram;
   507.
   508.    begin
   509.       total := summed_counts(from => the_histogram'First, to => the_histogram'Last);
   510.       if total = 0 then
   511.          log_title("The histogram of executed instructions is empty.");
   512.          return;
   513.       end if;
   514.       -- Print the instruction execution-frequency histogram.
   515.       log_title("Histogram of"
   516.               & KDF9.order_counter'Image(total)
   517.               & " executed instructions.");
   518.       log_histogram(bound => 0.0, with_bar_chart => True);
   519.       log_new_line;
   520.       log_rule;
   521.    end show_histogram;
   522.
   523.    function as_RFIR (K4_word : KDF9.word)
   524.    return KDF9.RFIR is
   525.       mask : KDF9.word := 2**16;
   526.       RFIR : KDF9.RFIR := (others => False);
   527.    begin
   528.       for r in reverse KDF9.interrupt_number loop
   529.          if (K4_word and mask) /= 0 then
   530.             RFIR(r) := True;
   531.          end if;
   532.          mask := 2 * mask;
   533.       end loop;
   534.       return RFIR;
   535.    end as_RFIR;
   536.
   537.    procedure show_retro_FIFO is
   538.       RFIR_id : constant array (KDF9.interrupt_number) of Character
   539.               := ('P', 'F', 'I', 'N', 'E', 'S', 'O', 'R', 'Y', 'Z');
   540.       image   : String(1 .. 18);
   541.       RFIR    : KDF9.RFIR;
   542.    begin
   543.       if retro_FIFO_count = 0 then
   544.          return;
   545.       end if;
   546.       log_title("Retrospective trace of all instructions.");
   547.       tab_log_to(60);
   548.       log_line(" ND SD VT  CPU TIME    ICR");
   549.       for i in 1 .. retro_FIFO_count loop
   550.          if i = 1 then
   551.             log("Ended ");
   552.          else
   553.             log("After ");
   554.          end if;
   555.          declare
   556.             this    : tracing.retro_FIFO_entry renames retro_FIFO(retro_FIFO_index);
   557.             decoded : KDF9.decoded_order;
   558.          begin
   559.             log(oct_of(this.location) & ":");
   560.             tab_log_to(17);
   561.             flush;
   562.             decoded.order := this.order;
   563.             decode(decoded);
   564.             log(the_name_of(decoded));
   565.             tab_log_to(33);
   566.             case decoded.kind is
   567.                when one_syllable_order =>
   568.                   if this.nested > 0 then
   569.                      case decoded.syndrome is
   570.                         when DIV
   571.                            | DIVR
   572.                            | DIVD
   573.                            | X_frac =>
   574.                            log(CPU.fraction'Image(fractional(this.parameter)));
   575.                         when DIVI =>
   576.                            log(CPU.signed'Image(resign(this.parameter)));
   577.                         when STAND
   578.                            | ABSF
   579.                            | DIVDF
   580.                            | DIVF
   581.                            | FLOAT_9
   582.                            | FLOATD
   583.                            | MINUSDF
   584.                            | MINUSF
   585.                            | NEGDF
   586.                            | NEGF
   587.                            | PLUSDF
   588.                            | PLUSF
   589.                            | ROUNDF
   590.                            | ROUNDHF
   591.                            | XDF
   592.                            | XF
   593.                            | XPLUSF
   594.                            | MAXF =>
   595.                            Put(image,
   596.                                host_float(CPU.float(this.parameter)), Aft => 11, Exp => 2);
   597.                            log(trimmed(image));
   598.                         when others =>
   599.                            if this.nested > 0 then
   600.                               log_octal(this.parameter);
   601.                            end if;
   602.                      end case;
   603.                   end if;
   604.                when two_syllable_order =>
   605.                   case decoded.syndrome is
   606.                      when PARQq
   607.                         | PIAQq_PICQq_CLOQq_TLOQq
   608.                         | PIBQq_PIDQq
   609.                         | PIEQq_PIGQq
   610.                         | PIFQq_PIHQq
   611.                         | PMAQq_PMKQq_INTQq
   612.                         | CTQq_PMBQq_PMCQq_BUSYQq
   613.                         | PMDQq_PMEQq_PMLQq
   614.                         | PMFQq
   615.                         | POAQq_POCQq_POEQq_POFQq
   616.                         | POBQq_PODQq
   617.                         | POGQq_POLQq
   618.                         | POHQq_POKQq =>
   619.                         show_Q_register(as_Q(this.parameter), with_FD_C_part => True);
   620.                      when M_PLUS_Iq
   621.                         | M_MINUS_Iq
   622.                         | NCq
   623.                         | DCq
   624.                         | POS1_TO_Iq
   625.                         | NEG1_TO_Iq
   626.                         | POS2_TO_Iq
   627.                         | NEG2_TO_Iq
   628.                         | CqTOQk
   629.                         | IqTOQk
   630.                         | MqTOQk
   631.                         | QqTOQk
   632.                         | CIqTOQk
   633.                         | IMqTOQk
   634.                         | CMqTOQk
   635.                         | TO_RCIMq
   636.                         | ADD_TO_QCIMq
   637.                         | JCqNZS =>
   638.                         show_Q_register(as_Q(this.parameter));
   639.                      when Kk =>
   640.                         case decoded.Qk is
   641.                            when K4 =>
   642.                               log(KDF9.word'Image(32*KDF9.word(as_Q(this.parameter).C)));
   643.                               log("us");
   644.                               if as_Q(this.parameter).I /= 0 then
   645.                                  log("; RFIR: ");
   646.                                  RFIR := as_RFIR(this.parameter);
   647.                                  for r in KDF9.interrupt_number loop
   648.                                     if RFIR(r) then
   649.                                        log(RFIR_id(r)&"");
   650.                                     end if;
   651.                                  end loop;
   652.                               end if;
   653.                               if resign(this.parameter) < 0 then
   654.                                  log("C");
   655.                               end if;
   656.                            when K5 | K7 =>
   657.                               log_octal(this.parameter);
   658.                            when others =>
   659.                               trap_invalid_instruction;
   660.                         end case;
   661.                      when TO_LINK =>
   662.                         log(oct_of(as_link(this.parameter)));
   663.                      when LINK =>
   664.                         log(oct_of(as_link(this.parameter)));
   665.                      when TO_MkMq
   666.                         | TO_MkMqQ
   667.                         | TO_MkMqH
   668.                         | TO_MkMqQH
   669.                         | TO_MkMqN
   670.                         | TO_MkMqQN
   671.                         | TO_MkMqHN
   672.                         | TO_MkMqQHN =>
   673.                         log_octal(this.parameter);
   674.                      when others =>
   675.                         if this.nested > 0 then
   676.                            log_octal(this.parameter);
   677.                         end if;
   678.                   end case;
   679.                when normal_jump_order =>
   680.                   case decoded.syndrome is
   681.                      when Jr
   682.                         | JSr =>
   683.                         log(oct_of(as_link(this.parameter)));
   684.                      when EXIT_9 =>
   685.                         if this.parameter < 8 then
   686.                            log(KDF9.word'Image(this.parameter));
   687.                         else
   688.                            log(oct_of(as_link(this.parameter)));
   689.                         end if;
   690.                      when JrCqZ
   691.                         | JrCqNZ =>
   692.                         show_Q_register(as_Q(this.parameter));
   693.                      when OUT_9 =>
   694.                         if this.parameter < 64 then
   695.                            log(KDF9.word'Image(this.parameter));
   696.                         elsif this.parameter > 2**47 then
   697.                            log_octal(this.parameter);
   698.                         else
   699.                            show_Q_register(as_Q(this.parameter));
   700.                         end if;
   701.                      when JrEJ
   702.                         | JrNEJ
   703.                         | JrEN
   704.                         | JrNEN =>
   705.                            log(KDF9.word'Image(this.parameter));
   706.                      when JrTR
   707.                         | JrV =>
   708.                            log(Boolean'Image(Boolean'Val(this.parameter)));
   709.                      when JrNTR
   710.                         | JrNV =>
   711.                            log(Boolean'Image(not Boolean'Val(this.parameter)));
   712.                      when others =>
   713.                         if this.nested > 0 then
   714.                            log_octal(this.parameter);
   715.                         end if;
   716.                      end case;
   717.                when others =>
   718.                   if this.nested > 0 then
   719.                      log_octal(this.parameter);
   720.                   end if;
   721.             end case;
   722.             tab_log_to(60);
   723.             log(justified(KDF9.nest_depth'Image(this.nested),3));
   724.             log(justified(KDF9.sjns_depth'Image(this.called),3));
   725.             log(" ");
   726.             if this.V /= 0 then
   727.                log("V");
   728.             end if;
   729.             if this.T /= 0 then
   730.                log("T");
   731.             end if;
   732.             tab_log_to(70);
   733.             log(KDF9.microseconds'Image(this.CPU_time));
   734.             tab_log_to(82);
   735.             log(KDF9.order_counter'Image(this.ICR_value));
   736.             log_new_line;
   737.          end;
   738.          retro_FIFO_index := retro_FIFO_index - 1;
   739.       end loop;
   740.       if retro_FIFO_count = FIFO_size then
   741.          log("After earlier instructions, whose tracing is now lost.");
   742.       else
   743.          log("After the start of traced execution.");
   744.       end if;
   745.       log_new_line;
   746.       log_rule;
   747.    end show_retro_FIFO;
   748.
   749.    procedure show_IOC_FIFO is
   750.    begin
   751.       if IOC_FIFO_count = 0 then return; end if;
   752.       log_title("Retrospective trace of peripheral I/O events.");
   753.       tab_log_to(64);
   754.       log_line(" CPL     EL. TIME    ICR");
   755.       for i in 1 .. IOC_FIFO_count loop
   756.          if i = 1 then
   757.             log("Ended ");
   758.          else
   759.             log("After ");
   760.          end if;
   761.          declare
   762.             this : tracing.IOC_FIFO_entry renames IOC_FIFO(IOC_FIFO_index);
   763.          begin
   764.             log(oct_of(this.order_address) & ":");
   765.             tab_log_to(17);
   766.             if the_name_of(this.decoded_order) ="OUT" then
   767.                log(the_name_of(this.decoded_order)&"8");
   768.             else
   769.                log(the_name_of(this.decoded_order));
   770.             end if;
   771.             tab_log_to(30);
   772.             log(this.device_name);
   773.             case this.kind is
   774.                when store_lockout =>
   775.                   tab_log_to(34);
   776.                   log("Store Lockout at #");
   777.                   log(oct_of(this.data_address));
   778.                   tab_log_to(70);
   779.                   log(" @"
   780.                     & KDF9.microseconds'Image(this.initiation_time));
   781.                   tab_log_to(84);
   782.                   log(KDF9.order_counter'Image(this.ICR_value));
   783.                 when buffer_lockout =>
   784.                   tab_log_to(34);
   785.                   log("Buffer Lockout");
   786.                   tab_log_to(70);
   787.                   log(" @"
   788.                     & KDF9.microseconds'Image(this.initiation_time));
   789.                   tab_log_to(84);
   790.                   log(KDF9.order_counter'Image(this.ICR_value));
   791.                when start_transfer =>
   792.                   tab_log_to(34);
   793.                   show_Q_register(this.control_word, with_FD_C_part => True);
   794.                   tab_log_to(62);
   795.                   if this.is_for_Director then
   796.                      log(" D");
   797.                   else
   798.                      log(" P");
   799.                   end if;
   800.                   log(KDF9.priority'Image(this.priority_level));
   801.                   tab_log_to(70);
   802.                   log(" S"
   803.                     & KDF9.microseconds'Image(this.initiation_time));
   804.                   tab_log_to(84);
   805.                   log(KDF9.order_counter'Image(this.ICR_value));
   806.                when finis_transfer =>
   807.                   tab_log_to(34);
   808.                   show_Q_register(this.control_word, with_FD_C_part => True);
   809.                   tab_log_to(62);
   810.                   if this.is_for_Director then
   811.                      log(" D");
   812.                   else
   813.                      log(" P");
   814.                   end if;
   815.                   log(KDF9.priority'Image(this.priority_level));
   816.                   tab_log_to(70);
   817.                   log(" E"
   818.                     & KDF9.microseconds'Image(this.completion_time));
   819.                   tab_log_to(84);
   820.                   log(KDF9.order_counter'Image(this.ICR_value));
   821.                when test_buffer_status =>
   822.                   tab_log_to(34);
   823.                   show_Q_register(this.Q_register, with_FD_C_part => True);
   824.                   tab_log_to(62);
   825.                   log(" = ");
   826.                   log(Boolean'Image(this.status /= 0));
   827.                   tab_log_to(70);
   828.                   log(" @"
   829.                     & KDF9.microseconds'Image(this.initiation_time));
   830.                   tab_log_to(84);
   831.                   log(KDF9.order_counter'Image(this.ICR_value));
   832.             end case;
   833.             log_new_line;
   834.          end;
   835.          IOC_FIFO_index := IOC_FIFO_index - 1;
   836.       end loop;
   837.       if IOC_FIFO_count = FIFO_size then
   838.          log_line("After earlier instructions, whose tracing is now lost.");
   839.       else
   840.          log_line("After the start of traced execution.");
   841.       end if;
   842.       log_line("Total time waiting for unoverlapped I/O to finish ="
   843.              & KDF9.microseconds'Image((the_clock_time-the_CPU_time+500) / 1000)
   844.              & "ms.");
   845.       log_rule;
   846.    end show_IOC_FIFO;
   847.
   848.    procedure show_interrupt_FIFO is
   849.    begin
   850.       if interrupt_FIFO_count = 0 then return; end if;
   851.       log_title("Retrospective trace of interrupt requests.");
   852.       tab_log_to(54);
   853.       log_line(" CPL     EL. TIME    ICR");
   854.       for i in 1 .. interrupt_FIFO_count loop
   855.          if i = 1 then
   856.             log("Ended ");
   857.          else
   858.             log("After ");
   859.          end if;
   860.          declare
   861.             this : tracing.interrupt_FIFO_entry renames interrupt_FIFO(interrupt_FIFO_index);
   862.          begin
   863.             log(oct_of(this.order_address) & ": ");
   864.             case this.interrupt_code is
   865.                when PR_flag =>
   866.                   log("PR ");
   867.                when FLEX_flag =>
   868.                   log("FLEX ");
   869.                when LIV_flag =>
   870.                   log("LIV ");
   871.                when NOUV_flag =>
   872.                   log("NOUV ");
   873.                when EDT_flag =>
   874.                   log("EDT ");
   875.                when OUT_flag =>
   876.                   log("OUT ");
   877.                when LOV_flag =>
   878.                   log("LOV ");
   879.                when RESET_flag =>
   880.                   log("RESET");
   881.                when others =>
   882.                   log("?? ");
   883.                   log(KDF9.interrupt_number'Image(this.interrupt_code));
   884.             end case;
   885.             tab_log_to(52);
   886.             if this.in_Director then
   887.                log(" D");
   888.             else
   889.                log(" P");
   890.             end if;
   891.             log(KDF9.priority'Image(this.priority_level));
   892.             tab_log_to(60);
   893.             log(" @"
   894.               & KDF9.microseconds'Image(this.busy_time));
   895.             tab_log_to(74);
   896.             log(KDF9.order_counter'Image(this.ICR_value));
   897.             log_new_line;
   898.          end;
   899.          interrupt_FIFO_index := interrupt_FIFO_index - 1;
   900.       end loop;
   901.       if interrupt_FIFO_count = FIFO_size then
   902.          log("After earlier interrupts, whose tracing is now lost.");
   903.       else
   904.          log("After the start of traced execution.");
   905.       end if;
   906.       log_new_line;
   907.       log_new_line;
   908.    end show_interrupt_FIFO;
   909.
   910.    procedure show_retrospective_traces is
   911.    begin
   912.       if the_histogram_is_enabled  then
   913.          show_histogram;
   914.       end if;
   915.       if the_interrupt_trace_is_enabled then
   916.          show_interrupt_FIFO;
   917.       end if;
   918.       if the_peripheral_trace_is_enabled then
   919.          show_IOC_FIFO;
   920.       end if;
   921.       if the_retrospective_trace_is_enabled then
   922.          show_retro_FIFO;
   923.       end if;
   924.    exception
   925.       when error : others =>
   926.          log_new_line;
   927.          log_rule;
   928.          log_error_message("Failure in ee9: unexpected exception "
   929.                          & Exception_Information(error)
   930.                          & " was raised in 'show_retrospective_traces'!");
   931.          raise emulation_failure;
   932.    end show_retrospective_traces;
   933.
   934.    procedure show_current_state is
   935.    begin
   936.       show_execution_context;
   937.       log_rule;
   938.       show_registers;
   939.       log_rule;
   940.    end show_current_state;
   941.
   942.    procedure show_final_state is
   943.    begin
   944.       if the_signature_is_enabled then
   945.          log_title("Digital signature of traced orders = #"
   946.                  & oct_of(the_digital_signature)
   947.                  & ".");
   948.       end if;
   949.       if the_log_is_wanted and the_final_state_is_wanted then
   950.          log_new_line;
   951.          log_rule;
   952.          log_title("Final State:");
   953.          long_witness;
   954.          log_rule;
   955.          if ICR = 0 then
   956.             return;
   957.          end if;
   958.          if nr_of_post_dumping_areas /= 0 then
   959.             log_title("Post-run Dump:");
   960.             print_postrun_dump_areas;
   961.          end if;
   962.          show_retrospective_traces;
   963.       end if;
   964.       if the_log_is_wanted then
   965.          log_title("End of Run.");
   966.       end if;
   967.    end show_final_state;
   968.
   969.    procedure show_all_prerun_dump_areas is
   970.    begin
   971.       if the_log_is_wanted and nr_of_pre_dumping_areas /= 0 then
   972.          log_title("Pre-run Dump:");
   973.          print_prerun_dump_areas;
   974.          remove_prerun_dump_areas;
   975.       end if;
   976.    exception
   977.       when error : others =>
   978.          log_new_line;
   979.          log_rule;
   980.          log_error_message("Failure in ee9: unexpected exception "
   981.                          & Exception_Information(error)
   982.                          & " was raised in 'show_all_prerun_dump_areas'!");
   983.          raise emulation_failure;
   984.    end show_all_prerun_dump_areas;
   985.
   986.    quantum     : constant := 8;
   987.    jump_tab    : constant := 12;
   988.    first_tab   : constant := 16;
   989.    last_column : constant := 80;
   990.
   991.    function is_non_blank (first : in KDF9.address)
   992.    return Boolean is
   993.       result : Boolean := False;
   994.    begin
   995.       for address in first .. first+quantum-1 loop
   996.          result := result or (fetch_word(address) /= 0);
   997.       end loop;
   998.       return result;
   999.    end is_non_blank;
  1000.
  1001.    subtype converted_word is String(1..8);
  1002.
  1003.    type convertor is not null access function (address : KDF9.address) return converted_word;
  1004.
  1005.    procedure show_core (first, last : in KDF9.address;
  1006.                         head, side  : in String;
  1007.                         conversion  : in convertor) is
  1008.
  1009.       procedure show_group (first : in KDF9.address) is
  1010.          address : KDF9.address := first;
  1011.       begin
  1012.          while address <= first+quantum-1 loop
  1013.             log(conversion(address));
  1014.             address := address + 1;
  1015.             exit when address < first;
  1016.          end loop;
  1017.       end show_group;
  1018.
  1019.       address, last_address : KDF9.address := first;
  1020.
  1021.    begin
  1022.       if (last-first+1) < 1 then
  1023.          return;
  1024.       end if;
  1025.       log_title("Core store interpreted as " & head & ":");
  1026.       while address <= last loop
  1027.          if is_non_blank(address) then
  1028.             log_octal(KDF9.field_of_16_bits(address));
  1029.             log(":");
  1030.             tab_log_to(jump_tab);
  1031.             log(side);
  1032.             log(" """);
  1033.             show_group(address);
  1034.             log("""");
  1035.             log_new_line;
  1036.          elsif is_non_blank(last_address) then
  1037.             log_line("======  blank  ======");
  1038.          end if;
  1039.          last_address := address;
  1040.       exit when address >= KDF9.address'Last - quantum;
  1041.          address := address + quantum;
  1042.       end loop;
  1043.       log_new_line;
  1044.    end show_core;
  1045.
  1046.    function encoding_of (address : KDF9.address; code_table : output_code_table)
  1047.    return converted_word is
  1048.       result : converted_word;
  1049.    begin
  1050.       for b in KDF9.symbol_number loop
  1051.          result(Natural(b)+1) := glyph_for(code_table(fetch_symbol(address, b)));
  1052.       end loop;
  1053.       return result;
  1054.    end encoding_of;
  1055.
  1056.    current_case : KDF9.symbol := KDF9.Case_Normal;
  1057.
  1058.    function interpretation_of (address : KDF9.address)
  1059.    return converted_word is
  1060.       result : converted_word;
  1061.       symbol : KDF9.symbol;
  1062.       char   : Character;
  1063.    begin
  1064.       for b in KDF9.symbol_number loop
  1065.          symbol := fetch_symbol(address, b);
  1066.          if current_case = KDF9.Case_Normal then
  1067.             char := TP_CN(symbol);
  1068.          else
  1069.             char := TP_CS(symbol);
  1070.          end if;
  1071.          if symbol = KDF9.Case_Normal then
  1072.             current_case := KDF9.Case_Normal;
  1073.          elsif symbol = KDF9.Case_Shift then
  1074.             current_case := KDF9.Case_Shift;
  1075.          end if;
  1076.          result(Natural(b)+1) := glyph_for(char);
  1077.       end loop;
  1078.       return result;
  1079.    end interpretation_of;
  1080.
  1081.    function case_visible (address : KDF9.address)
  1082.    return converted_word is
  1083.    begin
  1084.       return interpretation_of(address);
  1085.    end case_visible;
  1086.
  1087.    function case_normal (address : KDF9.address)
  1088.    return converted_word is
  1089.    begin
  1090.       return encoding_of(address, code_table => TP_CN);
  1091.    end case_normal;
  1092.
  1093.    function case_shift (address : KDF9.address)
  1094.    return converted_word is
  1095.    begin
  1096.       return encoding_of(address, code_table => TP_CS);
  1097.    end case_shift;
  1098.
  1099.    function printer_code (address : KDF9.address)
  1100.    return converted_word is
  1101.    begin
  1102.       return encoding_of(address, code_table => to_LP);
  1103.    end printer_code;
  1104.
  1105.    function card_code (address : KDF9.address)
  1106.    return converted_word is
  1107.    begin
  1108.       return encoding_of(address, code_table => to_CP);
  1109.    end card_code;
  1110.
  1111.    function Latin_1_code (address : KDF9.address)
  1112.    return converted_word is
  1113.    begin
  1114.       return converted_word'(1..7 => Space,
  1115.                                 8 => glyph_for(Character'Val(fetch_word(address) and 8#377#)));
  1116.    end Latin_1_code;
  1117.
  1118.    procedure show_core_in_case_visible (first, last : in KDF9.address) is
  1119.    begin
  1120.       show_core(first, last,
  1121.                 head => "characters in TR/TP code with case shifting",
  1122.                 side => "  ",
  1123.                 conversion => case_visible'Access);
  1124.    end show_core_in_case_visible;
  1125.
  1126.    procedure show_core_in_case_normal (first, last : in KDF9.address) is
  1127.    begin
  1128.       show_core(first, last,
  1129.                 head => "characters in TR/TP Normal Case code",
  1130.                 side => "NC",
  1131.                 conversion => case_normal'Access);
  1132.    end show_core_in_case_normal;
  1133.
  1134.    procedure show_core_in_case_shift (first, last : in KDF9.address) is
  1135.    begin
  1136.       show_core(first, last,
  1137.                 head => "characters in TR/TP Shift Case code",
  1138.                 side => "SC",
  1139.                 conversion => case_shift'Access);
  1140.    end show_core_in_case_shift;
  1141.
  1142.    procedure show_core_in_print_code (first, last : in KDF9.address) is
  1143.    begin
  1144.       show_core(first, last,
  1145.                 head => "characters in LP code",
  1146.                 side => "LP",
  1147.                 conversion => printer_code'Access);
  1148.    end show_core_in_print_code;
  1149.
  1150.    procedure show_core_in_card_code (first, last : in KDF9.address) is
  1151.    begin
  1152.       show_core(first, last,head => "characters in CR/CP code",
  1153.                 side => "CP",
  1154.                 conversion => card_code'Access);
  1155.    end show_core_in_card_code;
  1156.
  1157.    procedure show_core_in_Latin_1 (first, last : in KDF9.address) is
  1158.    begin
  1159.       show_core(first, last,
  1160.                 head => "words with bits 40-47 of each in Latin_1 code",
  1161.                 side => "L1",
  1162.                 conversion => Latin_1_code'Access);
  1163.    end show_core_in_Latin_1;
  1164.
  1165.    procedure show_core_in_tape_code (first, last : in KDF9.address) is
  1166.    begin
  1167.       show_core_in_case_visible(first, last);
  1168.    end show_core_in_tape_code;
  1169.
  1170.    procedure show_core_as_word_forms (first, last  : KDF9.address) is
  1171.
  1172.       procedure show_word (address : KDF9.address) is
  1173.          word : constant KDF9.word := fetch_word(address);
  1174.       begin
  1175.          log_octal(KDF9.field_of_16_bits(address));
  1176.          log(":");
  1177.          tab_log_to(jump_tab);
  1178.          show_in_various_formats(word, column => jump_tab);
  1179.          log_new_line;
  1180.          log_new_line;
  1181.       end show_word;
  1182.
  1183.       procedure show_word_group (first, last  : KDF9.address) is
  1184.          last_address : KDF9.address := first;
  1185.          this_word, last_word : KDF9.word;
  1186.       begin
  1187.          this_word := fetch_word(first);
  1188.          last_word := this_word;
  1189.          show_word(first);
  1190.          for address in first+1 .. last-1 loop
  1191.             this_word := fetch_word(address);
  1192.             if this_word = last_word and address = last_address+1 then
  1193.                log_line("========  ditto  ========");
  1194.             elsif this_word /= last_word then
  1195.                show_word(address);
  1196.                last_word := this_word;
  1197.                last_address := address;
  1198.             end if;
  1199.          end loop;
  1200.          if last > first then
  1201.             show_word(last);
  1202.          end if;
  1203.       end show_word_group;
  1204.
  1205.    begin
  1206.       if first > last then
  1207.          return;
  1208.       end if;
  1209.       log_title("Core store interpreted as 48-bit words:");
  1210.       show_word_group(first, last);
  1211.       log_new_line;
  1212.    end show_core_as_word_forms;
  1213.
  1214.    -- Each word of code space is described by a set of flags.
  1215.    -- Flags 0 .. 5 are set iff a jump order has that syllable as target.
  1216.    -- Flag 6 is set if the word is though to be code, but not a target.
  1217.    -- Flag 7 is set if the word is though to be addressed as data.
  1218.
  1219.    is_a_code_word : constant KDF9.syllable_code := 6;
  1220.    is_a_data_word : constant KDF9.syllable_code := 7;
  1221.
  1222.    package word_flags is new generic_sets(member => KDF9.syllable_code);
  1223.    use word_flags;
  1224.
  1225.    all_jump_targets : constant word_flags.set := (0 .. 5 => True, 6|7 => False);
  1226.
  1227.    code_space_word : array (KDF9.code_location) of word_flags.set;
  1228.
  1229.    procedure show_code_space_marks_for (the_operand : in KDF9.code_location) is
  1230.    begin
  1231.       log(oct_of(KDF9.code_point'(0, the_operand)));
  1232.       for s in KDF9.syllable_code range 0 .. 5 loop
  1233.          if code_space_word(the_operand)(s) then
  1234.             log("" & Character'Val(Character'Pos('0')+Natural(s)));
  1235.          else
  1236.             log(" ");
  1237.          end if;
  1238.       end loop;
  1239.       if code_space_word(the_operand)(is_a_code_word) then
  1240.          log("CODE");
  1241.       else
  1242.          log("    ");
  1243.       end if;
  1244.       if code_space_word(the_operand)(is_a_data_word) then
  1245.          log(" DATA");
  1246.       else
  1247.          log("     ");
  1248.       end if;
  1249.       log_new_line;
  1250.    end show_code_space_marks_for;
  1251.    pragma Unreferenced(show_code_space_marks_for);
  1252.
  1253.    -- This is the entry point to the program, designated by the jump in E0.
  1254.    P0_start_point : KDF9.code_point;
  1255.    P0_start_word  : KDF9.code_location; -- = P0_start_point.word_number
  1256.
  1257.    function "/" (word : KDF9.code_location; flag : KDF9.syllable_code)
  1258.    return Boolean is
  1259.    begin
  1260.       return code_space_word(word)(flag);
  1261.    end "/";
  1262.
  1263.    function is_a_jump_target (the_point : in KDF9.code_point)
  1264.    return Boolean;
  1265.    pragma Inline(is_a_jump_target);
  1266.
  1267.    function is_a_jump_target (the_operand : in KDF9.code_location)
  1268.    return Boolean;
  1269.
  1270.    pragma Inline(is_a_jump_target);
  1271.
  1272.    function is_a_jump_target (the_point : in KDF9.code_point)
  1273.    return Boolean is
  1274.    begin
  1275.       return the_point.word_number >= P0_start_word and then
  1276.              code_space_word(the_point.word_number)(the_point.syllable_number);
  1277.    end is_a_jump_target;
  1278.
  1279.    function is_a_jump_target (the_operand : in KDF9.code_location)
  1280.    return Boolean is
  1281.    begin
  1282.       return the_operand >= P0_start_word and then
  1283.              (code_space_word(the_operand) and all_jump_targets) /= empty_set;
  1284.    end is_a_jump_target;
  1285.
  1286.    procedure clear_all_code_space_words is
  1287.    begin
  1288.       code_space_word := (others => empty_set);
  1289.    end clear_all_code_space_words;
  1290.
  1291.    procedure unmark_as_a_data_word (the_operand : in KDF9.code_location) is
  1292.    begin
  1293.       code_space_word(the_operand)(is_a_data_word) := False;
  1294.    end unmark_as_a_data_word;
  1295.
  1296.    procedure unmark_as_a_code_word (the_operand : in KDF9.code_location) is
  1297.    begin
  1298.       code_space_word(the_operand)(is_a_code_word) := False;
  1299.    end unmark_as_a_code_word;
  1300.
  1301.    procedure mark_as_a_code_word (the_operand : in KDF9.code_location) is
  1302.    begin
  1303.       code_space_word(the_operand)(is_a_code_word) := True;
  1304.       unmark_as_a_data_word(the_operand);
  1305.    end mark_as_a_code_word;
  1306.
  1307.    procedure mark_as_a_jump_target (the_point : in KDF9.code_point) is
  1308.    begin
  1309.       code_space_word(the_point.word_number)(the_point.syllable_number) := True;
  1310.       mark_as_a_code_word(the_point.word_number);
  1311.    end mark_as_a_jump_target;
  1312.
  1313.    procedure mark_as_a_data_word (the_operand : in KDF9.code_location) is
  1314.    begin
  1315.       code_space_word(the_operand)(is_a_data_word) := True;
  1316.       unmark_as_a_code_word(the_operand);
  1317.    end mark_as_a_data_word;
  1318.
  1319.    procedure mark_all_code_blocks_and_data_blocks is
  1320.
  1321.       procedure mark_all_code_blocks (the_beginning : in KDF9.code_point) is
  1322.          address : KDF9.code_point := the_beginning;
  1323.       begin
  1324.          if address.syllable_number > 5 then
  1325.             return;  -- We have blundered into non-code words.
  1326.          end if;
  1327.          -- Mark the first syllable of the block.
  1328.          mark_as_a_jump_target(the_beginning);
  1329.          -- Mark the destinations of all jumps in the block as code.
  1330.          loop
  1331.             set_NIA_to(address);
  1332.             decode_the_next_order;
  1333.             if is_an_invalid_order(INS)                                             or else
  1334.                   (address.word_number/is_a_data_word and address.syllable_number = 0) then
  1335.                return;
  1336.             else
  1337.                -- Assuming a valid code word, act on it.
  1338.                mark_as_a_code_word(address.word_number);
  1339.                case INS.kind is
  1340.                   when normal_jump_order =>
  1341.                      if not is_a_jump_target((INS.target.syllable_number, INS.target.word_number))
  1342.                             and INS.target.word_number >= P0_start_word then
  1343.                         -- Mark the jump's destination recursively.
  1344.                         -- N.B. EXIT is actioned only if it is of EXIT ARr type.
  1345.                         mark_all_code_blocks((INS.target.syllable_number, INS.target.word_number));
  1346.                      end if;
  1347.                      increment_by_3(address);
  1348.                      if INS.syndrome = JSr  then
  1349.                         -- Mark its return point.
  1350.                         mark_as_a_jump_target(address);
  1351.                      end if;
  1352.                   when one_syllable_order =>
  1353.                      increment_by_1(address);
  1354.                   when two_syllable_order =>
  1355.                      if INS.syndrome = JCqNZS then
  1356.                         -- Mark the preceding word.
  1357.                         mark_as_a_jump_target((0, address.word_number-1));
  1358.                      end if;
  1359.                      increment_by_2(address);
  1360.                   when data_access_order =>
  1361.                      increment_by_3(address);
  1362.                end case;
  1363.             end if;
  1364.             exit when address.word_number = KDF9.code_location'Last;
  1365.          end loop;
  1366.       end mark_all_code_blocks;
  1367.
  1368.       procedure mark_all_data_blocks (the_beginning : in KDF9.code_point) is
  1369.          address : KDF9.code_point := the_beginning;
  1370.       begin
  1371.          if address.syllable_number > 5 then
  1372.             return;  -- We have blundered into non-code words.
  1373.          end if;
  1374.          the_code_block_handler: loop
  1375.             -- Process orders, starting at an established code word.
  1376.             set_NIA_to(address);
  1377.             decode_the_next_order;
  1378.             if (is_an_invalid_order(INS)                   or else
  1379.                   address.word_number/is_a_data_word)     and then
  1380.                      not (address.word_number/is_a_code_word) then
  1381.                -- This word is data: make sure it is not designated as code;
  1382.                --    and find the start of the next code block.
  1383.                for a in address.word_number .. KDF9.code_location'Last loop
  1384.                   address := (0, a);
  1385.                   exit when is_a_jump_target(a);
  1386.                   unmark_as_a_code_word(a);
  1387.                   mark_as_a_data_word(a);
  1388.                end loop;
  1389.
  1390.                exit the_code_block_handler
  1391.                   when address.word_number = KDF9.code_location'Last;
  1392.
  1393.                -- Find the syllable at which the block starts.
  1394.                for s in KDF9.syllable_code'(0) .. 5 loop
  1395.                   address.syllable_number := s;
  1396.                   exit when is_a_jump_target(address);
  1397.                end loop;
  1398.
  1399.             else
  1400.
  1401.                -- Assuming a valid code word, act on it.
  1402.                case INS.kind is
  1403.                   when data_access_order =>
  1404.                      if INS.operand < 8192 then
  1405.                         declare
  1406.                            operand : constant KDF9.code_location
  1407.                                    := KDF9.code_location(INS.operand);
  1408.                         begin
  1409.                            if INS.syndrome /= KDF9.compressed_opcodes.SET and then
  1410.                                  not is_a_jump_target(operand)                then
  1411.                               mark_as_a_data_word(operand);
  1412.                            end if;
  1413.                         end;
  1414.                      end if;
  1415.                      increment_by_3(address);
  1416.                   when one_syllable_order =>
  1417.                      increment_by_1(address);
  1418.                   when two_syllable_order =>
  1419.                      increment_by_2(address);
  1420.                   when normal_jump_order =>
  1421.                      increment_by_3(address);
  1422.                end case;
  1423.             end if;
  1424.
  1425.             exit the_code_block_handler
  1426.                when address.word_number = KDF9.code_location'Last;
  1427.
  1428.          end loop the_code_block_handler;
  1429.       end mark_all_data_blocks;
  1430.
  1431.       procedure reset_wrong_data_marks (the_beginning : in KDF9.code_point) is
  1432.          address : KDF9.code_point := the_beginning;
  1433.          locus   : KDF9.code_location;
  1434.       begin
  1435.          if address.syllable_number > 5 then
  1436.             return;  -- We have blundered into non-code words.
  1437.          end if;
  1438.          -- Unmark the first instruction of the block.
  1439.          unmark_as_a_data_word(address.word_number);
  1440.
  1441.          -- Unmark data marks on destinations of jumps.
  1442.          loop
  1443.             set_NIA_to(address);
  1444.             decode_the_next_order;
  1445.             if is_an_invalid_order(INS)                    or else
  1446.                   address.word_number/is_a_data_word       or else
  1447.                      not (address.word_number/is_a_code_word) then
  1448.                -- We have reached the end of the code block.
  1449.                return;
  1450.             else
  1451.                -- Assuming a valid code word, act on it.
  1452.                case INS.kind is
  1453.                   when normal_jump_order =>
  1454.                      locus := address.word_number;
  1455.                      increment_by_3(address);
  1456.                      if INS.target.word_number >= P0_start_word and then
  1457.                            INS.target.word_number/is_a_data_word    then
  1458.                         -- UNmark the jump's destination recursively.
  1459.                         reset_wrong_data_marks((INS.target.syllable_number, INS.target.word_number));
  1460.                      end if;
  1461.                      if INS.syndrome /= Jr                           and then
  1462.                            (INS.syndrome /= EXIT_9 or
  1463.                             INS.target.word_number >= P0_start_word) and then
  1464.                               locus /= address.word_number               then
  1465.                         -- It flows on, so the next word cannot be data.
  1466.                         unmark_as_a_data_word(address.word_number);
  1467.                      elsif not (address.word_number/is_a_data_word) then
  1468.                         -- The next syllable starts a block, iff it is not the end of a block.
  1469.                         set_NIA_to(address);
  1470.                         decode_the_next_order;
  1471.                         if not is_an_invalid_order(INS) then
  1472.                            mark_as_a_jump_target(address);
  1473.                         end if;
  1474.                      end if;
  1475.                   when one_syllable_order =>
  1476.                      increment_by_1(address);
  1477.                   when two_syllable_order =>
  1478.                      increment_by_2(address);
  1479.                   when data_access_order =>
  1480.                      increment_by_3(address);
  1481.                end case;
  1482.             end if;
  1483.             exit when address.word_number = KDF9.code_location'Last;
  1484.          end loop;
  1485.       end reset_wrong_data_marks;
  1486.
  1487.    begin
  1488.       if the_code_space_has_been_marked then
  1489.          return;
  1490.       end if;
  1491.       clear_all_code_space_words;
  1492.
  1493.       if the_execution_mode /= boot_mode and the_initial_jump_was_corrupted then
  1494.          -- We cannot sensibly locate the order words using E0  ...
  1495.          log_new_line;
  1496.          log_line("The initial jump, in E0U, was corrupted by the program!");
  1497.          log_new_line;
  1498.          show_core_as_syllables((0, 0), (5, 0));
  1499.          --  ... so restore it to the value it had on loading.
  1500.          restore_the_initial_jump;
  1501.          log_line("E0U has been restored to the value it had on loading.");
  1502.          log_new_line;
  1503.       end if;
  1504.
  1505.       -- Ensure the right output format for the initial jump  ...
  1506.       mark_as_a_jump_target((0, 0));
  1507.       set_NIA_to((0, 0));
  1508.       loop
  1509.          decode_the_next_order;
  1510.          mark_as_a_code_word(CIA.word_number);
  1511.          exit when INS.kind = normal_jump_order;
  1512.       end loop;
  1513.
  1514.       --  ... and for subsequent words.
  1515.       for d in CIA.word_number+1 .. INS.target.word_number-1 loop
  1516.          mark_as_a_data_word(d);
  1517.       end loop;
  1518.
  1519.       -- Mark all code blocks reachable from the initial jump.
  1520.       set_NIA_to((0, 0));
  1521.       decode_the_next_order;
  1522.       P0_start_word  := INS.target.word_number;
  1523.       P0_start_point := (INS.target.syllable_number, INS.target.word_number);
  1524.       mark_all_code_blocks(P0_start_point);
  1525.
  1526.       -- Mark all words clearly referenced by data fetch/store orders.
  1527.       mark_all_data_blocks(P0_start_point);
  1528.
  1529.       -- Correct over-zealous marking of code as data or vice versa.
  1530.
  1531.       -- Unmark any order that was accidentally marked as data.
  1532.       reset_wrong_data_marks(P0_start_point);
  1533.
  1534.       -- Ensure right format for the initial jump  ...
  1535.       mark_as_a_jump_target((0, 0));
  1536.       set_NIA_to((0, 0));
  1537.       loop
  1538.          decode_the_next_order;
  1539.          mark_as_a_code_word(CIA.word_number);
  1540.          exit when INS.kind = normal_jump_order;
  1541.       end loop;
  1542.
  1543.       --  ... and for subsequent words.
  1544.       for d in CIA.word_number+1 .. INS.target.word_number-1 loop
  1545.          mark_as_a_data_word(d);
  1546.       end loop;
  1547.
  1548.       the_code_space_has_been_marked := True;
  1549.    end mark_all_code_blocks_and_data_blocks;
  1550.
  1551.    procedure show_core_as_Usercode (first, last  : in KDF9.code_point;
  1552.                                     octal_option : in Boolean) is
  1553.
  1554.       six_DUMMIES : constant KDF9.word := 8#0360741703607417#;
  1555.       saved_CIA   : constant KDF9.code_point := CIA;
  1556.       last_word   : KDF9.word := 8#0706050403020100#; -- invalid opcodes
  1557.       comparator  : KDF9.word := last_word;
  1558.       this_word   : KDF9.word;
  1559.       address     : KDF9.code_point;
  1560.
  1561.       procedure show_a_block_of_orders is
  1562.
  1563.          function is_a_store_order (decoded : KDF9.decoded_order)
  1564.          return Boolean is
  1565.          begin
  1566.             if decoded.kind = one_syllable_order then
  1567.                return False;
  1568.             elsif decoded.kind = two_syllable_order then
  1569.                case decoded.syndrome is
  1570.                   when TO_MkMq   | TO_MkMqQ
  1571.                      | TO_MkMqH  | TO_MkMqQH
  1572.                      | TO_MkMqN  | TO_MkMqQN
  1573.                      | TO_MkMqHN | TO_MkMqQHN =>
  1574.                      return True;
  1575.                   when others =>
  1576.                      return False;
  1577.                end case;
  1578.             elsif decoded.kind = data_access_order then
  1579.                case decoded.syndrome is
  1580.                   when TO_EaMq | TO_EaMqQ =>
  1581.                      return True;
  1582.                   when others =>
  1583.                      return False;
  1584.                end case;
  1585.             else
  1586.                return False;
  1587.             end if;
  1588.          end is_a_store_order;
  1589.
  1590.          procedure set_line_at_minimum (tab : in Natural) is
  1591.          begin
  1592.             if panel_logger.column < tab then
  1593.                tab_log_to(tab);
  1594.             end if;
  1595.          end set_line_at_minimum;
  1596.
  1597.          procedure set_line_at (tab : in Natural) is
  1598.          begin
  1599.             if panel_logger.column > tab then
  1600.                log_new_line;
  1601.             end if;
  1602.             if panel_logger.column < tab then
  1603.                tab_log_to(tab);
  1604.             end if;
  1605.          end set_line_at;
  1606.
  1607.          procedure set_at_new_line is
  1608.          begin
  1609.             if panel_logger.column > 1 then
  1610.                log_new_line;
  1611.             end if;
  1612.          end set_at_new_line;
  1613.
  1614.       begin -- show_a_block_of_orders
  1615.          this_word := fetch_word(KDF9.address(address.word_number));
  1616.
  1617.          if this_word+1 < 2 or this_word = six_DUMMIES then
  1618.             -- The word is not worth logging.
  1619.             address := (0, address.word_number+1);
  1620.             return;
  1621.          end if;
  1622.
  1623.          -- Log useful information about data words.
  1624.          if address.word_number/is_a_data_word then
  1625.             set_at_new_line;
  1626.          end if;
  1627.          loop
  1628.             if address.word_number/is_a_data_word then
  1629.                -- Display a line of data.
  1630.                log_new_line;
  1631.                log(oct_or_dec_of(address, octal_option) & ": ");
  1632.                set_line_at(jump_tab);
  1633.                show_in_various_formats(fetch_word(KDF9.address(address.word_number)),
  1634.                                        column => jump_tab);
  1635.                log_new_line;
  1636.                if address.word_number = last.word_number then
  1637.                   return;
  1638.                end if;
  1639.                address := (0, address.word_number+1);
  1640.             else
  1641.                log_new_line;
  1642.                exit;
  1643.             end if;
  1644.          end loop;
  1645.
  1646.          loop
  1647.
  1648.             this_word := fetch_word(KDF9.address(address.word_number));
  1649.             if this_word = comparator and this_word = last_word then
  1650.                -- The word is not worth logging.
  1651.                address := (0, address.word_number+1);
  1652.                return;
  1653.             end if;
  1654.
  1655.             if this_word+1 < 2 or this_word = six_DUMMIES then
  1656.                comparator := this_word;
  1657.             end if;
  1658.
  1659.             set_NIA_to(address);
  1660.             decode_the_next_order;
  1661.             if is_an_invalid_order(INS) then
  1662.                -- The word is not worth logging.
  1663.                address := (0, address.word_number+1);
  1664.                return;
  1665.             end if;
  1666.
  1667.             if is_a_jump_target(address) then
  1668.                -- Start a code paragraph, with its address for easy reference.
  1669.                set_at_new_line;
  1670.                log(oct_or_dec_of(address, octal_option) & ": ");
  1671.                log_new_line;
  1672.             end if;
  1673.
  1674.
  1675.             -- Set the tab position appropriately for the order type.
  1676.             case INS.kind is
  1677.                when one_syllable_order | data_access_order =>
  1678.                   set_line_at_minimum(first_tab);
  1679.                when two_syllable_order =>
  1680.                   case INS.syndrome is
  1681.                      when JCqNZS =>
  1682.                         set_line_at(jump_tab);
  1683.                      when  CTQq_PMBQq_PMCQq_BUSYQq
  1684.                         |  PARQq
  1685.                         |  PMFQq
  1686.                         |  PIAQq_PICQq_CLOQq_TLOQq
  1687.                         |  PIBQq_PIDQq
  1688.                         |  PIEQq_PIGQq
  1689.                         |  PIFQq_PIHQq
  1690.                         |  POAQq_POCQq_POEQq_POFQq
  1691.                         |  POBQq_PODQq
  1692.                         |  POGQq_POLQq
  1693.                         |  POHQq_POKQq
  1694.                         |  PMAQq_PMKQq_INTQq
  1695.                         |  PMAQq_PMKQq_INTQq+1
  1696.                         |  PMDQq_PMEQq_PMLQq
  1697.                         |  PMDQq_PMEQq_PMLQq+1 =>
  1698.                         set_line_at(first_tab);
  1699.                      when others =>
  1700.                         if panel_logger.column < first_tab then
  1701.                            set_line_at_minimum(first_tab);
  1702.                         end if;
  1703.                   end case;
  1704.                when normal_jump_order =>
  1705.                   set_line_at(jump_tab);
  1706.             end case;
  1707.
  1708.             -- Show the order in pseudo-Usercode format.
  1709.             log(the_name_of(INS, octal_option) &  "; ");
  1710.
  1711.             case INS.kind is
  1712.                when one_syllable_order =>
  1713.                   increment_by_1(address);
  1714.                when two_syllable_order =>
  1715.                   increment_by_2(address);
  1716.                when normal_jump_order | data_access_order =>
  1717.                   increment_by_3(address);
  1718.             end case;
  1719.
  1720.             if address.word_number = last.word_number then
  1721.                log_new_line;
  1722.                return;
  1723.             end if;
  1724.
  1725.             if (address.word_number+1)/is_a_data_word or
  1726.                   address.word_number > last.word_number then
  1727.                return;
  1728.             end if;
  1729.
  1730.             if is_a_store_order(INS)                   or else
  1731.                   INS.syndrome = JCqNZS                or else
  1732.                      INS.kind = normal_jump_order      or else
  1733.                         panel_logger.column > last_column then
  1734.                log_new_line;
  1735.             elsif this_word = comparator and this_word /= last_word then
  1736.                log_new_line;
  1737.                log_line("========  #"
  1738.                         & oct_of(KDF9.syllable(this_word and 255))
  1739.                         & "  ========");
  1740.                address := (0, address.word_number+1);
  1741.                if address.word_number > last.word_number or
  1742.                      address.word_number/is_a_data_word then
  1743.                   return;
  1744.                end if;
  1745.             end if;
  1746.
  1747.             last_word := this_word;
  1748.
  1749.          end loop;
  1750.
  1751.       end show_a_block_of_orders;
  1752.
  1753.    begin
  1754.       if the_code_space_has_been_marked then
  1755.          log_line("Core store interpreted as instructions.");
  1756.          address := first;
  1757.          loop
  1758.             show_a_block_of_orders;
  1759.             exit when address.word_number >= last.word_number;
  1760.          end loop;
  1761.          log_new_line;
  1762.          log_rule;
  1763.          CIA := saved_CIA;
  1764.          decode_the_next_order;
  1765.       else
  1766.          log_line(" ... Core store cannot be interpreted as instructions!");
  1767.          log_new_line;
  1768.       end if;
  1769.    end show_core_as_Usercode;
  1770.
  1771.    procedure show_core_as_syllables (first, last  : KDF9.code_point) is
  1772.
  1773.       address     :   KDF9.code_point;
  1774.
  1775.       procedure show_a_block is
  1776.
  1777.          procedure set_line_at (tab : Natural) is
  1778.          begin  -- set_line_at
  1779.             if panel_logger.column > tab then
  1780.                log_new_line;
  1781.             end if;
  1782.             if panel_logger.column < tab then
  1783.                tab_log_to(tab);
  1784.             end if;
  1785.          end set_line_at;
  1786.
  1787.       begin  -- show_a_block
  1788.          loop
  1789.             if address.syllable_number = 0 then
  1790.                log_new_line;
  1791.                log(oct_of(address) & ": ");
  1792.                set_line_at(jump_tab);
  1793.             end if;
  1794.             log(oct_of(fetch_syllable(address)) &  "; ");
  1795.             increment_by_1(address);
  1796.          exit when address.word_number > last.word_number;
  1797.          end loop;
  1798.          log_new_line;
  1799.       end show_a_block;
  1800.
  1801.     begin  -- show_core_as_syllables
  1802.       log_line("Core store interpreted as order syllables.");
  1803.       address := first;
  1804.       loop
  1805.          show_a_block;
  1806.          exit when address.word_number > last.word_number;
  1807.       end loop;
  1808.       log_new_line;
  1809.       log_rule;
  1810.    end show_core_as_syllables;
  1811.
  1812. end state_display;

Compiling: ../Source\state_display.ads
Source file time stamp: 2015-06-18 00:55:36
Compiled at: 2015-10-28 18:13:57

     1. -- state_display.ads
     2. --
     3. -- Provide the comprehensive machine-state display panel KDF9 never had.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9;
    20.
    21. use  KDF9;
    22.
    23. package state_display is
    24.
    25.    pragma Unsuppress(All_Checks);
    26.
    27.    procedure show_all_prerun_dump_areas;
    28.
    29.    procedure show_CIA_and_NIA;
    30.
    31.    procedure show_V_and_T;
    32.
    33.    procedure show_nest;
    34.
    35.    procedure show_sjns;
    36.
    37.    procedure show_Q_register (the_Q_register : in KDF9.Q_register;
    38.                               width          : in Positive := 8;
    39.                               with_FD_C_part : in Boolean  := False);
    40.
    41.    procedure show_Q_store;
    42.
    43.    procedure show_registers;
    44.
    45.    procedure show_execution_context;
    46.
    47.    procedure long_witness;
    48.
    49.    procedure short_witness;
    50.
    51.    procedure log_an_external_trace_header;
    52.
    53.    procedure log_to_external_trace;
    54.
    55.    procedure show_progress;
    56.
    57.    procedure show_Director_registers;
    58.
    59.    procedure show_retrospective_traces;
    60.
    61.    procedure show_current_state;
    62.
    63.    procedure show_final_state;
    64.
    65.    procedure mark_all_code_blocks_and_data_blocks;
    66.
    67.    the_code_space_has_been_marked : Boolean := False;
    68.
    69.    procedure show_core_as_word_forms (first, last : in KDF9.address);
    70.
    71.    procedure show_core_as_syllables (first, last : in KDF9.code_point);
    72.
    73.    procedure show_core_as_Usercode (first, last  : in KDF9.code_point;
    74.                                     octal_option : in Boolean);
    75.
    76.    procedure show_core_in_print_code (first, last : in KDF9.address);
    77.
    78.    procedure show_core_in_card_code (first, last : in KDF9.address);
    79.
    80.    procedure show_core_in_tape_code (first, last : in KDF9.address);
    81.
    82.    procedure show_core_in_case_normal (first, last : in KDF9.address);
    83.
    84.    procedure show_core_in_case_shift (first, last : in KDF9.address);
    85.
    86.    procedure show_core_in_Latin_1 (first, last : in KDF9.address);
    87.
    88. end state_display;

 1812 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\formatting.adb
Source file time stamp: 2015-06-18 00:56:48
Compiled at: 2015-10-28 18:14:09

     1. -- formatting.adb
     2. --
     3. -- Provide basic data-formatting operations.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Characters.Handling;
    20. with Ada.Strings;
    21. with Ada.Strings.Fixed;
    22.
    23. use  Ada.Characters.Handling;
    24. use  Ada.Strings;
    25. use  Ada.Strings.Fixed;
    26.
    27. package body formatting is
    28.
    29.    pragma Unsuppress(All_Checks);
    30.
    31.    -- Return N as 3 octal digits.
    32.    function oct_of (N : KDF9.syllable)
    33.    return String is
    34.    begin
    35.       return oct_of(KDF9.halfword(N))(6 .. 8);
    36.    end oct_of;
    37.
    38.    -- Return N as 6 octal digits.
    39.    function oct_of (N : KDF9.field_of_16_bits)
    40.    return String is
    41.       value : KDF9.field_of_16_bits := N;
    42.       oct   : String(1 .. 6);
    43.    begin
    44.       for i in reverse oct'Range loop
    45.          oct(i) := digit_map(KDF9.halfword(value mod 8));
    46.          value := value / 8;
    47.       end loop;
    48.       return oct;
    49.    end oct_of;
    50.
    51.    -- Return N as 1 .. min_digits octal digits, with (partial) zero suppression.
    52.    function oct_of (N : KDF9.Q_part; min_digits : octal_width := 6)
    53.    return String is
    54.       oct : constant String(octal_width) := oct_of(KDF9.field_of_16_bits(N));
    55.    begin
    56.      if N = 0 then return (1..min_digits => '0'); end if;
    57.      for i in 1 .. 6-min_digits loop
    58.         if oct(i) /= '0' then
    59.            return oct(i .. 6);
    60.         end if;
    61.       end loop;
    62.       return oct(7-min_digits .. 6);
    63.    end oct_of;
    64.
    65.    -- Return N as decimal digits, with zero suppression.
    66.    function dec_of (N : KDF9.Q_part)
    67.    return String is
    68.       dec : constant String := KDF9.Q_part'Image(N);
    69.    begin
    70.       return trimmed(dec);
    71.    end dec_of;
    72.
    73.    -- Return N as 5 octal digits.
    74.    function oct_of (N : KDF9.code_location)
    75.    return String is
    76.       value : KDF9.code_location := N;
    77.       oct   : String(1 .. 5);
    78.    begin
    79.       for i in reverse oct'Range loop
    80.          oct(i) := digit_map(KDF9.halfword(value mod 8));
    81.          value := value / 8;
    82.       end loop;
    83.       return oct;
    84.    end oct_of;
    85.
    86.    -- Return N as 8 octal digits.
    87.    function oct_of (N : KDF9.halfword)
    88.    return String is
    89.       value : KDF9.halfword := N;
    90.       oct   : String(1 .. 8);
    91.    begin
    92.       for i in reverse oct'Range loop
    93.          oct(i) := digit_map(value mod 8);
    94.          value := value / 8;
    95.       end loop;
    96.       return oct;
    97.    end oct_of;
    98.
    99.    -- Return N as #wwwww/s, where w and s are octal digits.
   100.    function oct_of (N : KDF9.code_link)
   101.    return String is
   102.       image : constant String  := '#'
   103.                                 &  oct_of(N.word_number)
   104.                                 & '/'
   105.                                 & digit_map(KDF9.halfword(N.syllable_number));
   106.    begin
   107.       return image;
   108.    end oct_of;
   109.
   110.    -- Return N as #wwwww/s, where w and s are octal digits.
   111.    function oct_of (N : KDF9.code_point)
   112.    return String is
   113.    begin
   114.       return oct_of(KDF9.code_link(N));
   115.    end oct_of;
   116.
   117.    -- Return N as dddd/d, where d is a decimal digit.
   118.    function dec_of (N : KDF9.code_point)
   119.    return String is
   120.       image : constant String  := trimmed(KDF9.code_location'Image(N.word_number))
   121.                                 & '/'
   122.                                 & digit_map(KDF9.halfword(N.syllable_number));
   123.    begin
   124.       return image;
   125.    end dec_of;
   126.
   127.    -- Return N as #wwwww/s, where w and s are octal digits;
   128.    --    or as dddd/s, where d is a decimal digit, according to octal_option.
   129.    function oct_or_dec_of (N : KDF9.code_point; octal_option : Boolean)
   130.    return String is
   131.    begin
   132.       return optional(octal_option, oct_of(N), dec_of(N));
   133.    end oct_or_dec_of;
   134.
   135.    -- Return N as 16 octal digits
   136.    function oct_of (N : KDF9.word)
   137.    return String is
   138.       value : KDF9.word := N;
   139.       oct   : String(1 .. 16);
   140.    begin
   141.       for i in reverse oct'Range loop
   142.          oct(i) := digit_map(KDF9.halfword(value mod 8));
   143.          value := value / 8;
   144.       end loop;
   145.       return oct;
   146.    end oct_of;
   147.
   148.    -- Return "L', R'", or "L'" if R' is empty; "'" indicates removal of trailing blanks.
   149.    function "-" (L, R : String) return String is
   150.       trim_R : constant String := trim(R, right);
   151.    begin
   152.       if trim_R /= "" then
   153.          return trim(L, right) & ", " & trim_R;
   154.       else
   155.          return trim(L, right);
   156.       end if;
   157.    end "-";
   158.
   159.    -- Return S with all leading an trailing blanks removed.
   160.    function trimmed (S : String) return String is
   161.    begin
   162.       return trim(S, Ada.Strings.both);
   163.    end trimmed;
   164.
   165.    -- Return trimmed(S), right-justified in a field of width at least W.
   166.    function justified (S : String; W : Positive := 3)
   167.    return String is
   168.      image   : constant String   := trim(S, Ada.Strings.both);
   169.      columns : constant Positive := Positive'Max(W, image'Length);
   170.    begin
   171.      return tail(image, columns, ' ');
   172.    end justified;
   173.
   174.    -- Return (if B then S else ""): for pre-Ada 2012 compliers.
   175.    function optional (B : Boolean; T : String)
   176.    return String is
   177.    begin
   178.      if B then return T; else return ""; end if;
   179.    end optional;
   180.
   181.    -- Return (if B then S else T): for pre-Ada 2012 compliers.
   182.    function optional (B : Boolean; S, T : String)
   183.    return String is
   184.    begin
   185.      if B then return S; else return T; end if;
   186.    end optional;
   187.
   188.    -- Return C converted to a 1-character string.
   189.    function "+" (C : Character) return unit_string is
   190.       result : unit_string;
   191.    begin
   192.       result(1) := C;
   193.       return result;
   194.    end "+";
   195.
   196.    -- Return C with all Latin-1 lower-case letters converted to upper-case.
   197.    function to_upper (C : Character)
   198.    return Character is
   199.    begin
   200.       return Ada.Characters.Handling.to_upper(C);
   201.    end to_upper;
   202.
   203.    -- Return S with all Latin-1 lower-case letters converted to upper-case.
   204.    function to_upper (S : String)
   205.    return String is
   206.    begin
   207.       return Ada.Characters.Handling.to_upper(S);
   208.    end to_upper;
   209.
   210.    -- Return C with all Latin-1 upper-case letters converted to lower-case.
   211.    function to_lower (C : Character)
   212.    return Character is
   213.    begin
   214.       return Ada.Characters.Handling.to_lower(C);
   215.    end to_lower;
   216.
   217.    -- Return S with all Latin-1 upper-case letters converted to lower-case.
   218.    function to_lower (S : String)
   219.    return String is
   220.    begin
   221.       return Ada.Characters.Handling.to_lower(S);
   222.    end to_lower;
   223.
   224.    -- Return the 8-character Latin-1 string representing the 8 Case Normal characters in N.
   225.    function to_string (N : KDF9.word)
   226.    return word_as_byte_string is
   227.       word   : KDF9.word := N;
   228.       result : word_as_byte_string;
   229.    begin
   230.       for i in reverse 1 .. 8 loop
   231.          result(i) := KDF9.TP_CN(KDF9.symbol(word and 8#77#));
   232.          word := word / 64;
   233.       end loop;
   234.       return result;
   235.    end to_string;
   236.
   237.    -- Return the result of applying to_string to each word of a double-word.
   238.    function to_string (P : KDF9.pair)
   239.    return pair_as_byte_string is
   240.       result : pair_as_byte_string;
   241.    begin
   242.       result(1 ..  8) := to_string(P.msw);
   243.       result(9 .. 16) := to_string(P.lsw);
   244.       return result;
   245.    end to_string;
   246.
   247. end formatting;

Compiling: ../Source\formatting.ads
Source file time stamp: 2015-06-18 00:56:48
Compiled at: 2015-10-28 18:14:09

     1. -- formatting.ads
     2. --
     3. -- Provide basic data-formatting operations.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9;
    20.
    21. use  KDF9;
    22.
    23. package formatting is
    24.
    25.    pragma Unsuppress(All_Checks);
    26.
    27.    digit_map : constant array (KDF9.halfword range 0 .. 15) of Character := "0123456789ABCDEF";
    28.
    29.    subtype unit_string               is String(1 .. 1);
    30.    subtype word_as_byte_string       is String(1 .. 8);
    31.    subtype pair_as_byte_string       is String(1 .. 16);
    32.
    33.    -- Return N as 3 octal digits.
    34.    function oct_of (N : KDF9.syllable)
    35.    return String;
    36.
    37.    -- Return N as 6 octal digits.
    38.    function oct_of (N : KDF9.field_of_16_bits)
    39.    return String;
    40.
    41.    subtype octal_width is Positive range 1 .. 6;
    42.
    43.    -- Return N as octal digits, with (partial) zero suppression.
    44.    -- The first (6-min_digits) are elided if '0'; all remaining digits are returned.
    45.    -- Up to 6 digits can be returned if the result is longer than min_digits.
    46.    -- If N is 0, the String (1..min_digits => '0') is returned.
    47.    function oct_of (N : KDF9.Q_part; min_digits : octal_width := 6)
    48.    return String;
    49.
    50.    -- Return N as 1 .. 6 decimal digits, with zero suppression.
    51.    function dec_of (N : KDF9.Q_part)
    52.    return String;
    53.
    54.    -- Return N as 5 octal digits.
    55.    function oct_of (N : KDF9.code_location)
    56.    return String;
    57.
    58.    -- Return N as 8 octal digits.
    59.    function oct_of (N : KDF9.halfword)
    60.    return String;
    61.
    62.    -- Return N as #wwwww/s, where w and s are octal digits.
    63.    function oct_of (N : KDF9.code_link)
    64.    return String;
    65.
    66.    -- Return N as #wwwww/s, where w and s are octal digits.
    67.    function oct_of (N : KDF9.code_point)
    68.    return String;
    69.
    70.    -- Return N as dddd/d, where d is a decimal digit.
    71.    function dec_of (N : KDF9.code_point)
    72.    return String;
    73.
    74.    -- Return N as #wwwww/s, where w and s are octal digits;
    75.    --    or as dddd/s, where d is a decimal digit, according to octal_option.
    76.    function oct_or_dec_of (N : KDF9.code_point; octal_option : Boolean)
    77.    return String;
    78.
    79.    -- Return N as 16 octal digits
    80.    function oct_of (N : KDF9.word)
    81.    return String;
    82.
    83.    -- Return "L', R'", or "L'" if R' is empty: "'" indicates removal of trailing blanks.
    84.    function "-" (L, R : String)
    85.    return String;
    86.
    87.    -- Return S with all leading an trailing blanks removed.
    88.    function trimmed (S : String)
    89.    return String;
    90.
    91.    -- Return trimmed(S), right-justified in a field of width at least W.
    92.    function justified (S : String; W : Positive := 3)
    93.    return String;
    94.
    95.    -- Return (if B then S else ""): for pre-Ada 2012 compliers.
    96.    function optional (B : Boolean; T : String)
    97.    return String;
    98.
    99.    -- Return (if B then S else T): for pre-Ada 2012 compliers.
   100.    function optional (B : Boolean; S, T : String)
   101.    return String;
   102.
   103.    -- Return C converted to a 1-character string.
   104.    function "+" (C : Character)
   105.    return unit_string;
   106.
   107.    -- Return C with all Latin-1 lower-case letters converted to upper-case.
   108.    function to_upper (C : Character)
   109.    return Character;
   110.
   111.    -- Return S with all Latin-1 lower-case letters converted to upper-case.
   112.    function to_upper (S : String)
   113.    return String;
   114.
   115.    -- Return C with all Latin-1 upper-case letters converted to lower-case.
   116.    function to_lower (C : Character)
   117.    return Character;
   118.
   119.    -- Return S with all Latin-1 upper-case letters converted to lower-case.
   120.    function to_lower (S : String)
   121.    return String;
   122.
   123.    -- Return the 8-character Latin-1 string representing the 8 Case Normal characters in N.
   124.    function to_string (N : KDF9.word)
   125.    return word_as_byte_string;
   126.
   127.    -- Return the result of applying to_string to each word of a double-word.
   128.    function to_string (P : KDF9.pair)
   129.    return pair_as_byte_string;
   130.
   131. end formatting;

 247 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\generic_logger.adb
Source file time stamp: 2015-06-18 00:56:48
Compiled at: 2015-10-28 18:14:11

     1. -- generic_logger.adb
     2. --
     3. -- Provide operations supporting replicated output
     4. --    output to a list of logging interfaces.
     5. --
     6. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     7. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     8. --
     9. -- The ee9 program is free software; you can redistribute it and/or
    10. -- modify it under terms of the GNU General Public License as published
    11. -- by the Free Software Foundation; either version 3, or (at your option)
    12. -- any later version. This program is distributed in the hope that it
    13. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    14. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    15. -- See the GNU General Public License for more details. You should have
    16. -- received a copy of the GNU General Public License distributed with
    17. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    18. --
    19.
    20. -- generic
    21. --    max_logger_list_size : in Positive;
    22. package body generic_logger is
    23.
    24.    pragma Unsuppress(All_Checks);
    25.
    26.    not overriding
    27.    procedure set_logger_list (logger : in out replicator; list : in distribution_list) is
    28.    begin
    29.       logger.data := (list'Length, list);
    30.    end set_logger_list;
    31.
    32.    overriding
    33.    procedure tab_log (logger   : in out replicator;
    34.                       at_least : in Natural;
    35.                       spacing  : in Positive;
    36.                       iff      : in Boolean := True) is
    37.    begin
    38.       for l in logger.data.list'Range loop
    39.          logger.data.list(l).tab_log(at_least, spacing, iff);
    40.       end loop;
    41.    end tab_log;
    42.
    43.    overriding
    44.    procedure tab_log_to (logger : in out replicator;
    45.                          column : in Positive;
    46.                          iff    : in Boolean := True) is
    47.    begin
    48.       for l in logger.data.list'Range loop
    49.          logger.data.list(l).tab_log_to(column, iff);
    50.       end loop;
    51.    end tab_log_to;
    52.
    53.    overriding
    54.    procedure log (logger : in out replicator;
    55.                   char   : in Character;
    56.                   iff    : in Boolean := True) is
    57.    begin
    58.       for l in logger.data.list'Range loop
    59.          logger.data.list(l).log(char, iff);
    60.       end loop;
    61.    end log;
    62.
    63.    overriding
    64.    procedure log (logger : in out replicator;
    65.                   text   : in String;
    66.                   iff    : in Boolean := True) is
    67.    begin
    68.       for l in logger.data.list'Range loop
    69.          logger.data.list(l).log(text, iff);
    70.       end loop;
    71.    end log;
    72.
    73.    overriding
    74.    procedure log_new_line (logger : in out replicator;
    75.                            iff    : in Boolean := True) is
    76.    begin
    77.       for l in logger.data.list'Range loop
    78.          logger.data.list(l).log_new_line(iff);
    79.       end loop;
    80.    end log_new_line;
    81.
    82.    overriding
    83.    procedure open (logger : in out replicator; log_name : in String) is
    84.    begin
    85.       for l in logger.data.list'Range loop
    86.          logger.data.list(l).open(log_name);
    87.       end loop;
    88.    end open;
    89.
    90.    overriding
    91.    procedure close (logger : in out replicator; log_name : in String) is
    92.    begin
    93.       for l in logger.data.list'Range loop
    94.          logger.data.list(l).close(log_name);
    95.       end loop;
    96.    end close;
    97.
    98.    overriding
    99.    procedure flush (logger : in out replicator; iff : in Boolean := True) is
   100.    begin
   101.       for l in logger.data.list'Range loop
   102.          logger.data.list(l).flush(iff);
   103.       end loop;
   104.    end flush;
   105.
   106. end generic_logger;

Compiling: ../Source\generic_logger.ads
Source file time stamp: 2015-06-18 00:56:46
Compiled at: 2015-10-28 18:14:11

     1. -- generic_logger.ads
     2. --
     3. -- Provide operations supporting replicated output to a list of logging interfaces.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with logging;
    20.
    21. generic
    22.    max_logger_list_size : in Positive;
    23. package generic_logger is
    24.
    25.    pragma Unsuppress(All_Checks);
    26.
    27.    type distribution_list is array (Positive range <>) of access logging.output'Class;
    28.
    29.    type replicator is new logging.output with private;
    30.
    31.    not overriding
    32.    procedure set_logger_list (logger : in out replicator; list : in distribution_list);
    33.
    34.    overriding
    35.    procedure tab_log (logger   : in out replicator;
    36.                       at_least : in Natural;
    37.                       spacing  : in Positive;
    38.                       iff      : in Boolean := True);
    39.
    40.    overriding
    41.    procedure tab_log_to (logger : in out replicator;
    42.                          column : in Positive;
    43.                          iff    : in Boolean := True);
    44.
    45.    overriding
    46.    procedure log (logger : in out replicator;
    47.                   char   : in Character;
    48.                   iff    : in Boolean := True);
    49.
    50.    overriding
    51.    procedure log (logger : in out replicator;
    52.                   text   : in String;
    53.                   iff    : in Boolean := True);
    54.
    55.    overriding
    56.    procedure log_new_line (logger : in out replicator;
    57.                            iff    : in Boolean := True);
    58.
    59.    overriding
    60.    procedure open  (logger : in out replicator; log_name : in String);
    61.
    62.    overriding
    63.    procedure close (logger : in out replicator; log_name : in String);
    64.
    65.    overriding
    66.    procedure flush (logger : in out replicator; iff : in Boolean := True);
    67.
    68. private
    69.
    70.    subtype logger_list_size is Natural range 0 .. max_logger_list_size;
    71.
    72.    -- This type is needed because tagged types cannot have discriminants.
    73.    type replica_list (length : logger_list_size := 0) is
    74.       record
    75.          list : distribution_list(1 .. length);
    76.       end record;
    77.
    78.    type replicator is new logging.output with
    79.       record
    80.          data : replica_list;
    81.       end record;
    82.
    83. end generic_logger;

 106 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\latin_1.ads
Source file time stamp: 2015-06-18 00:56:00
Compiled at: 2015-10-28 18:14:11

     1. -- latin_1.ads
     2. --
     3. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     4. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     5. --
     6. -- The ee9 program is free software; you can redistribute it and/or
     7. -- modify it under terms of the GNU General Public License as published
     8. -- by the Free Software Foundation; either version 3, or (at your option)
     9. -- any later version. This program is distributed in the hope that it
    10. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    11. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    12. -- See the GNU General Public License for more details. You should have
    13. -- received a copy of the GNU General Public License distributed with
    14. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    15. --
    16.
    17. with Ada.Characters.Latin_1;
    18.
    19. package Latin_1 renames Ada.Characters.Latin_1;
    20.

 20 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\logging.ads
Source file time stamp: 2015-06-18 00:55:56
Compiled at: 2015-10-28 18:14:11

     1. -- logging.ads
     2. --
     3. -- Define an abstract log output device.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package logging is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    type output is interface;
    24.
    25.    procedure tab_log (logger   : in out logging.output;
    26.                       at_least : in Natural;
    27.                       spacing  : in Positive;
    28.                       iff      : in Boolean := True) is abstract;
    29.
    30.    procedure tab_log_to (logger : in out logging.output;
    31.                          column : in Positive;
    32.                          iff    : in Boolean := True) is abstract;
    33.
    34.    procedure log (logger : in out logging.output;
    35.                   char   : in Character;
    36.                   iff    : in Boolean := True) is abstract;
    37.
    38.    procedure log (logger : in out logging.output;
    39.                   text   : in String;
    40.                   iff    : in Boolean := True) is abstract;
    41.
    42.    procedure log_new_line (logger : in out logging.output;
    43.                            iff    : in Boolean := True) is abstract;
    44.
    45.    procedure open  (logger : in out logging.output; log_name : in String) is abstract;
    46.
    47.    procedure close (logger : in out logging.output; log_name : in String) is abstract;
    48.
    49.    procedure flush (logger : in out logging.output; iff : in Boolean := True) is abstract;
    50.
    51. end logging;

 51 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\logging-file.adb
Source file time stamp: 2015-06-18 00:55:58
Compiled at: 2015-10-28 18:14:11

     1. -- file.adb
     2. --
     3. -- Provide logging output to a named text file.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Text_IO;
    20. with Ada.Unchecked_Deallocation;
    21. --
    22. with file_interfacing;
    23.
    24. use  Ada.Text_IO;
    25. --
    26. use  file_interfacing;
    27.
    28. package body logging.file is
    29.
    30.    pragma Unsuppress(All_Checks);
    31.
    32.    overriding
    33.    procedure tab_log (logger   : in out file.output;
    34.                       at_least : in Natural;
    35.                       spacing  : in Positive;
    36.                       iff      : in Boolean := True) is
    37.       column_nr : constant Positive_Count := Col(logger.the_log.all) + Count(at_least);
    38.       excess    : constant Count          := column_nr mod Count(spacing);
    39.    begin
    40.       if not iff or logger.log_file_is_shut then return; end if;
    41.       Set_Col(logger.the_log.all, column_nr);
    42.       if excess /= 0 then
    43.          Set_Col(logger.the_log.all, column_nr + Count(spacing) - excess);
    44.       end if;
    45.    end tab_log;
    46.
    47.    overriding
    48.    procedure tab_log_to (logger : in out file.output;
    49.                          column : in Positive;
    50.                          iff    : in Boolean := True) is
    51.    begin
    52.       if not iff or logger.log_file_is_shut then return; end if;
    53.       Set_Col(logger.the_log.all, Positive_Count(column));
    54.    end tab_log_to;
    55.
    56.    overriding
    57.    procedure log_new_line (logger : in out file.output;
    58.                            iff    : in Boolean := True) is
    59.    begin
    60.       if not iff or logger.log_file_is_shut then return; end if;
    61.       New_Line(logger.the_log.all);
    62.    end log_new_line;
    63.
    64.    overriding
    65.    procedure log (logger : in out file.output;
    66.                   char   : in Character;
    67.                   iff    : in Boolean := True) is
    68.    begin
    69.       if not iff or logger.log_file_is_shut then return; end if;
    70.       Put(logger.the_log.all, char);
    71.    end log;
    72.
    73.    overriding
    74.    procedure log (logger : in out file.output;
    75.                   text   : in String;
    76.                   iff    : in Boolean := True) is
    77.    begin
    78.       if not iff or logger.log_file_is_shut then return; end if;
    79.       Put(logger.the_log.all, text);
    80.    end log;
    81.
    82.    overriding
    83.    procedure open (logger : in out file.output; logfile_name : in String) is
    84.    begin
    85.       if logger.log_file_is_shut then
    86.          logger.the_log := new Ada.Text_IO.File_Type;
    87.          file_interfacing.initialize(logger.the_log.all, out_file, logfile_name);
    88.          logger.log_file_is_shut := False;
    89.       end if;
    90.    end open;
    91.
    92.    overriding
    93.    procedure close (logger : in out file.output; logfile_name : in String) is
    94.
    95.       procedure free_log_file is
    96.          new Ada.Unchecked_Deallocation(Ada.Text_IO.File_Type, File_Type_access);
    97.
    98.    begin
    99.       if logger.log_file_is_shut then return; end if;
   100.       file_interfacing.finalize(logger.the_log.all, logfile_name);
   101.       free_log_file(logger.the_log);
   102.       logger.log_file_is_shut := True;
   103.    end close;
   104.
   105.    overriding
   106.    procedure flush (logger : in out file.output; iff : in Boolean := True) is
   107.    begin
   108.       if not iff or logger.log_file_is_shut then return; end if;
   109.       Flush(logger.the_log.all);
   110.    end flush;
   111.
   112. end logging.file;

Compiling: ../Source\logging-file.ads
Source file time stamp: 2015-06-18 00:55:58
Compiled at: 2015-10-28 18:14:11

     1. -- logging-file.ads
     2. --
     3. -- Provide logging output to a named text file.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. private with Ada.Text_IO;
    20.
    21. package logging.file is
    22.
    23.    pragma Unsuppress(All_Checks);
    24.
    25.    type output is new logging.output with private;
    26.
    27.    overriding
    28.    procedure tab_log (logger   : in out file.output;
    29.                       at_least : in Natural;
    30.                       spacing  : in Positive;
    31.                       iff      : in Boolean := True);
    32.
    33.    overriding
    34.    procedure tab_log_to (logger : in out file.output;
    35.                          column : in Positive;
    36.                          iff    : in Boolean := True);
    37.
    38.    overriding
    39.    procedure log (logger : in out file.output;
    40.                   char   : in Character;
    41.                   iff    : in Boolean := True);
    42.
    43.    overriding
    44.    procedure log (logger : in out file.output;
    45.                   text   : in String;
    46.                   iff    : in Boolean := True);
    47.
    48.    overriding
    49.    procedure log_new_line (logger : in out file.output;
    50.                            iff    : in Boolean := True);
    51.
    52.    overriding
    53.    procedure open  (logger : in out file.output; logfile_name : in String);
    54.
    55.    overriding
    56.    procedure close (logger : in out file.output; logfile_name : in String);
    57.
    58.    overriding
    59.    procedure flush (logger : in out file.output; iff    : in Boolean := True);
    60.
    61. private
    62.
    63.    type File_Type_access is access Ada.Text_IO.File_Type;
    64.
    65.    type output is new logging.output with
    66.       record
    67.          log_file_is_shut : Boolean := True;
    68.          the_log          : file.File_Type_access;
    69.       end record;
    70.
    71. end logging.file;

 112 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\logging-panel.adb
Source file time stamp: 2015-06-18 00:55:56
Compiled at: 2015-10-28 18:14:12

     1. -- logging-panel.adb
     2. --
     3. -- Provide logging output to an interactive terminal/control panel.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with OS_specifics;
    20. with POSIX;
    21. with settings;
    22.
    23. use  OS_specifics;
    24. use  POSIX;
    25. use  settings;
    26.
    27. package body logging.panel is
    28.
    29.    pragma Unsuppress(All_Checks);
    30.
    31.    not overriding
    32.    function column (logger : panel.display)
    33.    return Positive is
    34.    begin
    35.       return logger.column_number;
    36.    end column;
    37.
    38.    overriding
    39.    procedure tab_log (logger   : in out panel.display;
    40.                       at_least : in Natural;
    41.                       spacing  : in Positive;
    42.                       iff      : in Boolean := True) is
    43.       new_col : constant Natural := logger.column_number + at_least;
    44.       deficit : constant Natural := (spacing - new_col mod spacing) mod spacing;
    45.    begin
    46.       if not iff then return; end if;
    47.       for i in logger.column_number .. (new_col + deficit) loop
    48.          POSIX.output(' ');
    49.       end loop;
    50.       logger.column_number := new_col + deficit;
    51.    end tab_log;
    52.
    53.    overriding
    54.    procedure tab_log_to (logger : in out panel.display;
    55.                          column : in Positive;
    56.                          iff    : in Boolean := True) is
    57.    begin
    58.       if not iff then return; end if;
    59.       if column < logger.column_number then
    60.          logger.log_new_line;
    61.       end if;
    62.       for i in logger.column_number .. column-1 loop
    63.          POSIX.output(' ');
    64.       end loop;
    65.       logger.column_number := column;
    66.    end tab_log_to;
    67.
    68.    overriding
    69.    procedure log (logger : in out panel.display;
    70.                   char   : in Character;
    71.                   iff    : in Boolean := True) is
    72.    begin
    73.       if not iff then return; end if;
    74.       POSIX.output(char);
    75.       logger.column_number := logger.column_number + 1;
    76.    end log;
    77.
    78.    overriding
    79.    procedure log (logger : in out panel.display;
    80.                   text   : in String;
    81.                   iff    : in Boolean := True) is
    82.    begin
    83.       if not iff then return; end if;
    84.       POSIX.output(text);
    85.       logger.column_number := logger.column_number + text'Length;
    86.    end log;
    87.
    88.    overriding
    89.    procedure log_new_line (logger : in out panel.display;
    90.                            iff    : in Boolean := True) is
    91.    begin
    92.       if not iff then return; end if;
    93.       POSIX.output(EOL);
    94.       logger.column_number := 1;
    95.    end log_new_line;
    96.
    97.    not overriding
    98.    procedure show (logger : in out panel.display; message : in String := "") is
    99.    begin
   100.       if message /= "" then
   101.          logger.log_new_line;
   102.          logger.log(message);
   103.       end if;
   104.    end show;
   105.
   106.    not overriding
   107.    procedure show_line (logger : in out panel.display; message : in String := "") is
   108.    begin
   109.       if message /= "" then
   110.          logger.log_new_line;
   111.          logger.log(message);
   112.       end if;
   113.       logger.log_new_line;
   114.    end show_line;
   115.
   116.    not overriding
   117.    procedure respond_to_prompt (logger   : in out panel.display;
   118.                                 prompt   : in String;
   119.                                 response : out Character) is
   120.    begin
   121.       POSIX.prompt(prompt, response, default => ' ');
   122.       logger.column_number := 1;
   123.    end respond_to_prompt;
   124.
   125.    not overriding
   126.    procedure continue_when_GO_is_pressed (logger  : in out panel.display;
   127.                                           caption : in String := "") is
   128.       prompt   : constant String
   129.                := "Breakpoint:" & caption & " (f:ast | t:race | p:ause or q:uit)? ";
   130.       old_mode : constant settings.diagnostic_mode := the_diagnostic_mode;
   131.       response : Character;
   132.    begin
   133.       loop
   134.          logger.respond_to_prompt(prompt, response);
   135.          case response is
   136.             when 'q' | 'Q' =>
   137.                quit_was_requested := True;
   138.                return;
   139.             when ' ' =>
   140.                exit;
   141.             when 'f' | 'F' =>
   142.                set_diagnostic_mode(fast_mode);
   143.                exit;
   144.             when 'p' | 'P' =>
   145.                set_diagnostic_mode(pause_mode);
   146.                exit;
   147.             when 't' | 'T' =>
   148.                set_diagnostic_mode(trace_mode);
   149.                exit;
   150.             when others =>
   151.                null;
   152.          end case;
   153.       end loop;
   154.       the_diagnostic_mode_changed := (the_diagnostic_mode /= old_mode) or quit_was_requested;
   155.    end continue_when_GO_is_pressed;
   156.
   157. end logging.panel;

Compiling: ../Source\logging-panel.ads
Source file time stamp: 2015-06-18 00:55:56
Compiled at: 2015-10-28 18:14:12

     1. -- logging-panel.ads
     2. --
     3. -- Provide logging output to an interactive terminal/control panel.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package logging.panel is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    type display is new logging.output with private;
    24.
    25.    not overriding
    26.    function column (logger : panel.display)
    27.    return Positive;
    28.
    29.    overriding
    30.    procedure tab_log (logger   : in out panel.display;
    31.                       at_least : in Natural;
    32.                       spacing  : in Positive;
    33.                       iff      : in Boolean := True);
    34.
    35.    overriding
    36.    procedure tab_log_to (logger : in out panel.display;
    37.                          column : in Positive;
    38.                          iff    : in Boolean := True);
    39.
    40.    overriding
    41.    procedure log (logger : in out panel.display;
    42.                   char   : in Character;
    43.                   iff    : in Boolean := True);
    44.
    45.    overriding
    46.    procedure log (logger : in out panel.display;
    47.                   text   : in String;
    48.                   iff    : in Boolean := True);
    49.
    50.    overriding
    51.    procedure log_new_line (logger : in out panel.display;
    52.                            iff    : in Boolean := True);
    53.
    54.    not overriding
    55.    procedure show (logger : in out panel.display; message : in String := "");
    56.
    57.    not overriding
    58.    procedure show_line (logger : in out panel.display; message : in String := "");
    59.
    60.    not overriding
    61.    procedure respond_to_prompt (logger   : in out panel.display;
    62.                                 prompt   : in String;
    63.                                 response : out Character);
    64.
    65.    not overriding
    66.    procedure continue_when_GO_is_pressed (logger  : in out panel.display;
    67.                                           caption : in String := "");
    68.
    69.    overriding
    70.    procedure open (logger : in out panel.display; logfile_name : in String) is null;
    71.
    72.    overriding
    73.    procedure close (logger : in out panel.display; logfile_name : in String) is null;
    74.
    75.    overriding
    76.    procedure flush (logger : in out panel.display; iff : in Boolean := True) is null;
    77.
    78. private
    79.
    80.    type display is new logging.output with
    81.       record
    82.          column_number : Positive := 1;
    83.       end record;
    84.
    85. end logging.panel;

 157 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\dumping.adb
Source file time stamp: 2015-06-18 00:57:00
Compiled at: 2015-10-28 18:14:13

     1. -- dumping.adb
     2. --
     3. -- Provide support for diagnostic core-dumping area descriptions.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with formatting;
    20. with state_display;
    21.
    22. use  formatting;
    23. use  state_display;
    24.
    25. package body dumping is
    26.
    27.    pragma Unsuppress(All_Checks);
    28.
    29.    use dumping.flag_support;
    30.
    31.    function dumping_flag (c : Character) return dumping.flag is
    32.    begin
    33.       return dumping.flag(dumping.form'(to_upper(c)));
    34.    end dumping_flag;
    35.
    36.    type area is
    37.       record
    38.          format_set  : dumping.format_set := no_dumping_flag;
    39.          first, last : KDF9.address;
    40.       end record;
    41.
    42.    no_dumping_area : constant dumping.area := (no_dumping_flag, 0, 0);
    43.
    44.    dumping_area : array (dumping.area_number) of dumping.area := (others => no_dumping_area);
    45.
    46.    pre_dumping_area_count  : Natural range 0 .. nr_of_dumping_areas := 0;
    47.    post_dumping_area_count : Natural range 0 .. nr_of_dumping_areas := 0;
    48.
    49.    function nr_of_pre_dumping_areas
    50.    return dumping.area_count is
    51.    begin
    52.       return pre_dumping_area_count;
    53.    end nr_of_pre_dumping_areas;
    54.
    55.    function nr_of_post_dumping_areas
    56.    return dumping.area_count is
    57.    begin
    58.       return post_dumping_area_count;
    59.    end nr_of_post_dumping_areas;
    60.
    61.    procedure request_a_dumping_area (format_set  : in dumping.format_set;
    62.                                      first, last : in KDF9.address;
    63.                                      was_stored  : out Boolean) is
    64.    begin
    65.       was_stored := False;
    66.       if pre_dumping_area_count+post_dumping_area_count = nr_of_dumping_areas then
    67.          return;
    68.       end if;
    69.       for d in dumping_area'Range loop
    70.          if dumping_area(d) = (format_set, first, last) then
    71.             was_stored := True;
    72.             return;
    73.          end if;
    74.       end loop;
    75.       if format_set/expunge_dump_flag then
    76.          remove_specified_areas(format_set - expunge_dump_flag, first, last);
    77.       end if;
    78.       for d in dumping_area'Range loop
    79.          if dumping_area(d).format_set = no_dumping_flag then
    80.             dumping_area(d) := (format_set, first, last);
    81.             was_stored := True;
    82.             if initial_dump_flag/format_set then
    83.                pre_dumping_area_count := pre_dumping_area_count + 1;
    84.             end if;
    85.             if final_dump_flag/format_set then
    86.                post_dumping_area_count := post_dumping_area_count + 1;
    87.             end if;
    88.             return;
    89.          end if;
    90.       end loop;
    91.    end request_a_dumping_area;
    92.
    93.    max_types : constant Positive := abs is_dumping_flag - 1; -- P XOR Q
    94.
    95.    -- format_image returns no_specification if format_set is empty.
    96.    function format_image (format_set : dumping.format_set)
    97.    return String is
    98.       image_set  : dumping.format_set := format_set;
    99.       result     : String(1 .. max_types) := (others => ' ');
   100.       p          : Positive range 2 .. max_types := 2;
   101.    begin
   102.       if image_set = no_dumping_flag then
   103.          return result;
   104.       elsif image_set/initial_dump_flag then
   105.           image_set := image_set - initial_dump_flag;
   106.           result(1) := Character(initial_dump_flag);
   107.       else
   108.           image_set := image_set - final_dump_flag;
   109.           result(1) := Character(final_dump_flag);
   110.       end if;
   111.       for f in dumping.flag loop
   112.          if image_set/f then
   113.             result(p) := Character(f);
   114.             p := p + 1;
   115.          end if;
   116.       end loop;
   117.       return trimmed(result);
   118.    end format_image;
   119.
   120.    function area_image (d : dumping.area_number)
   121.    return String is
   122.       first       : constant KDF9.address := dumping_area(d).first;
   123.       last        : constant KDF9.address := dumping_area(d).last;
   124.       format_set  : constant dumping.format_set := dumping_area(d).format_set;
   125.       result      : String(1 .. max_types+2*(7)) := (others => ' ');
   126.    begin
   127.       if pre_dumping_area_count+post_dumping_area_count = 0 then
   128.          return no_specification;
   129.       end if;
   130.       result(1 .. max_types)             := format_image(format_set);
   131.       result(max_types+2 .. max_types+7) := oct_of(first);
   132.       result(max_types+9 .. result'Last) := oct_of(last);
   133.       return result;
   134.    end area_image;
   135.
   136.    procedure remove_specified_areas (format_set  : in dumping.format_set;
   137.                                      first, last : in KDF9.address) is
   138.    begin
   139.       if pre_dumping_area_count+post_dumping_area_count = 0 then
   140.          return;
   141.       end if;
   142.       for d in dumping_area'Range loop
   143.          if dumping_area(d).first >= first and dumping_area(d).last <= last then
   144.             dumping_area(d).format_set := dumping_area(d).format_set - format_set;
   145.             if dumping_area(d).format_set-initial_dump_flag-final_dump_flag = no_dumping_flag then
   146.                dumping_area(d) := no_dumping_area;
   147.             end if;
   148.             if initial_dump_flag/dumping_area(d).format_set then
   149.                pre_dumping_area_count := Integer'Max(pre_dumping_area_count - 1, 0);
   150.             end if;
   151.             if final_dump_flag/dumping_area(d).format_set then
   152.                post_dumping_area_count := Integer'Max(post_dumping_area_count - 1, 0);
   153.             end if;
   154.          end if;
   155.       end loop;
   156.    end remove_specified_areas;
   157.
   158.    procedure print_formatted_area (d : in dumping.area_number) is
   159.       format_set  : constant dumping.format_set := dumping_area(d).format_set;
   160.       first       : constant KDF9.address := dumping_area(d).first;
   161.       last        : constant KDF9.address := dumping_area(d).last;
   162.    begin
   163.       if format_set/tape_code_dump_flag then
   164.          show_core_in_tape_code(first, last);
   165.       end if;
   166.       if format_set/normal_dump_flag then
   167.          show_core_in_case_normal(first, last);
   168.       end if;
   169.       if format_set/shift_dump_flag then
   170.          show_core_in_case_shift(first, last);
   171.       end if;
   172.       if format_set/ card_code_dump_flag then
   173.          show_core_in_card_code(first, last);
   174.       end if;
   175.       if format_set/printer_dump_flag then
   176.          show_core_in_print_code(first, last);
   177.       end if;
   178.       if format_set/ASCII_dump_flag then
   179.          show_core_in_Latin_1(first, last);
   180.       end if;
   181.       if format_set/word_dump_flag then
   182.          show_core_as_word_forms(first, last);
   183.       end if;
   184.       if format_set/Usercode_dump_flag then
   185.          show_core_as_Usercode((0, KDF9.code_location(first)),
   186.                                (0, KDF9.code_location( last)),
   187.                                 octal_option => not format_set/decimal_dump_flag);
   188.       end if;
   189.       if format_set/orders_dump_flag then
   190.          show_core_as_syllables((0, KDF9.code_location(first)),
   191.                                 (0, KDF9.code_location( last)));
   192.       end if;
   193.    end print_formatted_area;
   194.
   195.    procedure print_prerun_dump_areas is
   196.    begin
   197.       if pre_dumping_area_count = 0 then
   198.          return;
   199.       end if;
   200.       mark_all_code_blocks_and_data_blocks;
   201.       for d in dumping_area'Range loop
   202.          if dumping_area(d).format_set/initial_dump_flag then
   203.             print_formatted_area(d);
   204.          end if;
   205.       end loop;
   206.    end print_prerun_dump_areas;
   207.
   208.    procedure remove_prerun_dump_areas is
   209.    begin
   210.       if pre_dumping_area_count = 0 then
   211.          return;
   212.       end if;
   213.       for d in dumping_area'Range loop
   214.          if dumping_area(d).format_set/initial_dump_flag then
   215.             dumping_area(d) := (no_dumping_flag, 0, 0);
   216.          end if;
   217.       end loop;
   218.       pre_dumping_area_count := 0;
   219.    end remove_prerun_dump_areas;
   220.
   221.    procedure print_postrun_dump_areas is
   222.    begin
   223.       if post_dumping_area_count = 0 then
   224.          return;
   225.       end if;
   226.       mark_all_code_blocks_and_data_blocks;
   227.       for d in dumping_area'Range loop
   228.          if dumping_area(d).format_set/final_dump_flag then
   229.             print_formatted_area(d);
   230.          end if;
   231.       end loop;
   232.    end print_postrun_dump_areas;
   233.
   234.    procedure remove_postrun_dump_areas is
   235.    begin
   236.       if post_dumping_area_count = 0 then
   237.          return;
   238.       end if;
   239.       for d in dumping_area'Range loop
   240.          if dumping_area(d).format_set/final_dump_flag then
   241.             dumping_area(d) := (no_dumping_flag, 0, 0);
   242.          end if;
   243.       end loop;
   244.       post_dumping_area_count := 0;
   245.    end remove_postrun_dump_areas;
   246.
   247. end dumping;

Compiling: ../Source\dumping.ads
Source file time stamp: 2015-06-18 00:57:00
Compiled at: 2015-10-28 18:14:13

     1. -- dumping.ads
     2. --
     3. -- Provide support for diagnostic core-dumping area descriptions.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9;
    20. with generic_sets; pragma Elaborate_All(generic_sets);
    21.
    22. use  KDF9;
    23.
    24. package dumping is
    25.
    26.    pragma Unsuppress(All_Checks);
    27.
    28.    type flag is new Character range '@' .. 'Z';
    29.
    30.    no_dump_flag        : constant dumping.flag := '@';
    31.    ASCII_dump_flag     : constant dumping.flag := 'A';
    32.    card_code_dump_flag : constant dumping.flag := 'C';
    33.    decimal_dump_flag   : constant dumping.flag := 'D';
    34.    single_dump_flag    : constant dumping.flag := 'E';
    35.    half_dump_flag      : constant dumping.flag := 'H';
    36.    initial_dump_flag   : constant dumping.flag := 'I';
    37.    normal_dump_flag    : constant dumping.flag := 'N';
    38.    orders_dump_flag    : constant dumping.flag := 'O';
    39.    printer_dump_flag   : constant dumping.flag := 'L';
    40.    shift_dump_flag     : constant dumping.flag := 'S';
    41.    tape_code_dump_flag : constant dumping.flag := 'T';
    42.    Usercode_dump_flag  : constant dumping.flag := 'U';
    43.    word_dump_flag      : constant dumping.flag := 'W';
    44.    expunge_dump_flag   : constant dumping.flag := 'X';
    45.    final_dump_flag     : constant dumping.flag := 'P';
    46.
    47.    subtype form is Character range Character(dumping.flag'First) .. Character(dumping.flag'Last);
    48.
    49.    function dumping_flag (c : Character) return dumping.flag;
    50.
    51.    package flag_support is new generic_sets(member => dumping.flag);
    52.
    53.    subtype format_set is flag_support.set;
    54.    use type format_set;
    55.    pragma Warnings(Off, format_set);
    56.
    57.    is_parameter_flag : constant dumping.format_set
    58.                      := (  decimal_dump_flag
    59.                          | single_dump_flag
    60.                          | half_dump_flag
    61.                          | ASCII_dump_flag
    62.                          | orders_dump_flag
    63.                          | printer_dump_flag
    64.                          | tape_code_dump_flag
    65.                          | Usercode_dump_flag
    66.                          | card_code_dump_flag
    67.                          | normal_dump_flag
    68.                          | shift_dump_flag
    69.                          | word_dump_flag     => True,
    70.                            others             => False
    71.                         );
    72.
    73.
    74.    is_epoch_flag : constant dumping.format_set
    75.                  := (  initial_dump_flag
    76.                      | final_dump_flag => True,
    77.                        others         => False
    78.                     );
    79.
    80.    is_dumping_flag  : constant dumping.format_set
    81.                     := is_parameter_flag or is_epoch_flag;
    82.
    83.    no_dumping_flag  : constant dumping.format_set
    84.                     := flag_support.empty_set;
    85.
    86.    nr_of_dumping_areas : constant := 100;
    87.
    88.    subtype area_count  is Natural  range 0 .. nr_of_dumping_areas;
    89.    subtype area_number is Positive range 1 .. nr_of_dumping_areas;
    90.
    91.    no_specification : constant String;
    92.
    93.    -- area_image returns no_specification if area(d) is undefined or empty.
    94.    function area_image (d : dumping.area_number)
    95.    return String;
    96.
    97.    -- format_image returns blanks if format_set is empty.
    98.    function format_image (format_set : dumping.format_set)
    99.    return String;
   100.
   101.    procedure request_a_dumping_area (format_set  : in dumping.format_set;
   102.                                      first, last : in KDF9.address;
   103.                                      was_stored  : out Boolean);
   104.
   105.    procedure remove_specified_areas (format_set  : in dumping.format_set;
   106.                                      first, last : in KDF9.address);
   107.
   108.    procedure print_prerun_dump_areas;
   109.
   110.    procedure remove_prerun_dump_areas;
   111.
   112.    procedure print_postrun_dump_areas;
   113.
   114.    procedure remove_postrun_dump_areas;
   115.
   116.    function nr_of_pre_dumping_areas
   117.    return dumping.area_count;
   118.
   119.    function nr_of_post_dumping_areas
   120.    return dumping.area_count;
   121.
   122. private
   123.
   124.    no_specification : constant String := "";
   125.
   126. end dumping;

 247 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\postscript.adb
Source file time stamp: 2015-06-18 00:55:46
Compiled at: 2015-10-28 18:14:15

     1. -- postscript.adb
     2. --
     3. -- Elementary Encapsulated PostScript (EPS) line drawing.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package body postscript is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    use IO;
    24.
    25.    the_PostScript_stream_access : access IO.stream;
    26.
    27.    procedure ensure_separation is
    28.    begin
    29.       if column(the_PostScript_stream_access.all) > 0 then
    30.          put_byte(' ', the_PostScript_stream_access.all);
    31.       end if;
    32.    end ensure_separation;
    33.
    34.    procedure put_fragment (PS_fragment : String) is
    35.    begin
    36.       put_bytes(PS_fragment, the_PostScript_stream_access.all);
    37.    end put_fragment;
    38.
    39.    procedure put_separate_fragment (PS_fragment : String) is
    40.    begin
    41.       ensure_separation;
    42.       put_fragment(PS_fragment);
    43.    end put_separate_fragment;
    44.
    45.    procedure put_fragment_and_a_new_line (PS_fragment : String) is
    46.    begin
    47.       put_fragment(PS_fragment);
    48.       put_EOL(the_PostScript_stream_access.all);
    49.    end put_fragment_and_a_new_line;
    50.
    51.    procedure put_separate_fragment_and_a_new_line (PS_fragment : String) is
    52.    begin
    53.       ensure_separation;
    54.       put_fragment(PS_fragment);
    55.       put_EOL(the_PostScript_stream_access.all);
    56.    end put_separate_fragment_and_a_new_line;
    57.
    58.    procedure put_integer_fragment (i : Integer) is
    59.       image  : constant String := Integer'Image(i);
    60.    begin
    61.       ensure_separation;
    62.       if image(image'First) /= ' ' then
    63.          put_fragment(image);
    64.       else  -- Suppress the nuisance blank character.
    65.          put_fragment(image(image'First+1..image'Last));
    66.       end if;
    67.    end put_integer_fragment;
    68.
    69.    -- A path is a series of vectors v1, v2, ..., vn such that the last point
    70.    --    of vi is the same as the first point of v(i+1),
    71.    --       and v1, ..., vn are all drawn in the same colour.
    72.    -- The vectors in a path are accumulated, and drawn only when the path is terminated
    73.    --    by a jump to a non-contiguous point or by a change of pen colour.
    74.
    75.    there_is_an_open_path      : Boolean := False;
    76.    the_last_point_in_the_path : postscript.point := (0, 0);
    77.
    78.    -- The bounding box limits are set from the value of maximum_offset at the end of the plot.
    79.    maximum_offset             : postscript.point := (0, 0);
    80.
    81.    procedure terminate_any_open_path is
    82.    begin
    83.       if there_is_an_open_path then
    84.          -- Draw the accumulated strokes.
    85.          put_separate_fragment_and_a_new_line("s");
    86.       end if;
    87.       there_is_an_open_path := False;
    88.    end terminate_any_open_path;
    89.
    90.    procedure draw_a_PostScript_vector (initial, final : in postscript.point) is
    91.
    92.       function largest_of (a, b, c : Natural) return Natural is
    93.       begin
    94.          return Natural'Max(a, Natural'Max(b, c));
    95.       end largest_of;
    96.       pragma Inline(largest_of);
    97.
    98.    begin
    99.       if initial /= the_last_point_in_the_path then
   100.          -- This vector is not contiguous with the previous one.
   101.          terminate_any_open_path;
   102.       end if;
   103.       if initial = final then
   104.          -- This vector is of length 0.
   105.          return;
   106.       end if;
   107.       maximum_offset.x := largest_of(maximum_offset.x, initial.x, final.x);
   108.       maximum_offset.y := largest_of(maximum_offset.y, initial.y, final.y);
   109.       if there_is_an_open_path then
   110.          -- Draw a line to the final point, extending the current path.
   111.          put_integer_fragment(final.x);
   112.          put_integer_fragment(final.y);
   113.          put_separate_fragment_and_a_new_line("l");
   114.       else
   115.          -- Move to the initial point, opening a fresh path, and draw a line to the final point.
   116.          put_integer_fragment(final.x);
   117.          put_integer_fragment(final.y);
   118.          put_integer_fragment(initial.x);
   119.          put_integer_fragment(initial.y);
   120.          put_separate_fragment_and_a_new_line("n");
   121.          there_is_an_open_path := True;
   122.       end if;
   123.       the_last_point_in_the_path := final;
   124.    end draw_a_PostScript_vector;
   125.
   126.    subtype RGB is String(1..11);
   127.    gamut : constant array (pen_colour) of RGB
   128.          := (
   129.                Black          => ".00 .00 .00",
   130.                Blue           => ".00 .00 1.0",
   131.                Brown          => ".60 .20 .00",
   132.                Cyan           => ".00 1.0 1.0",
   133.                Dark_Blue      => ".10 .10 .80",
   134.                Dark_Cyan      => ".20 .80 1.0",
   135.                Dark_Green     => ".00 .60 .40",
   136.                Dark_Grey      => ".50 .50 .50",
   137.                Dark_Magenta   => ".75 .25 .75",
   138.                Dark_Red       => ".75 .00 .00",
   139.                Green          => ".00 1.0 .00",
   140.                Grey           => ".80 .80 .80",
   141.                Magenta        => "1.0 .00 1.0",
   142.                Red            => "1.0 .00 .00",
   143.                White          => "1.0 1.0 1.0",
   144.                Yellow         => "1.0 1.0 .00"
   145.             );
   146.
   147.    the_colour  : pen_colour   := the_default_colour;
   148.    the_pen_tip : pen_tip_size := the_default_pen_tip;
   149.
   150.    procedure put_the_pen_settings is
   151.    begin
   152.       terminate_any_open_path;
   153.       case the_pen_tip is
   154.          when Extra_Extra_Fine =>
   155.             put_separate_fragment("1.0");
   156.          when Extra_Fine =>
   157.             put_separate_fragment("2.0");
   158.          when Fine =>
   159.             put_separate_fragment("4.0");
   160.          when Medium =>
   161.             put_separate_fragment("6.0");
   162.          when Medium_Broad =>
   163.             put_separate_fragment("8.0");
   164.          when Broad =>
   165.             put_separate_fragment("10.0");
   166.          when Extra_Broad =>
   167.             put_separate_fragment("12.0");
   168.       end case;
   169.       put_separate_fragment_and_a_new_line("setlinewidth");
   170.       put_separate_fragment(gamut(the_colour));
   171.       put_separate_fragment_and_a_new_line("setrgbcolor");
   172.    end put_the_pen_settings;
   173.
   174.    procedure set_the_pen_properties (this_colour  : in pen_colour   := the_default_colour;
   175.                                      this_pen_tip : in pen_tip_size := the_default_pen_tip) is
   176.    begin
   177.       the_colour  := this_colour;
   178.       the_pen_tip := this_pen_tip;
   179.       if the_PostScript_stream_access /= null     and then
   180.             is_open(the_PostScript_stream_access.all) then
   181.          put_the_pen_settings;
   182.       end if;
   183.    end set_the_pen_properties;
   184.
   185.    -- We eventually seek back to the bounding box parametsrs using this, their file offset.
   186.    the_position_of_the_placeholders : Natural;
   187.
   188.    procedure initialize_PostScript_output (the_GP_stream : in out IO.Stream) is
   189.    begin
   190.       if the_PostScript_stream_access /= null then
   191.          finalize_PostScript_output;
   192.          raise postscript_error with "PostScript was already initialized";
   193.       end if;
   194.       the_PostScript_stream_access := the_GP_stream'Unchecked_Access;
   195.
   196.       put_fragment_and_a_new_line("%!PS-Adobe-3.0 EPSF-1.0");
   197.       put_separate_fragment("%%BoundingBox: ");
   198.
   199.       -- Note the file offset of the bounding box placeholders.
   200.       get_position(the_position_of_the_placeholders, the_PostScript_stream_access.all);
   201.
   202.       -- Write the 10-column placeholders.
   203.       put_fragment_and_a_new_line("xxxxxxxxxx|yyyyyyyyyy");
   204.
   205.       put_separate_fragment_and_a_new_line("% This graph was plotted by ee9, the GNU Ada KDF9 emulator.");
   206.       put_separate_fragment_and_a_new_line("% For more information, see <http://www.findlayw.plus.com/KDF9>.");
   207.       put_separate_fragment_and_a_new_line("save");
   208.
   209.       put_separate_fragment_and_a_new_line("1 setlinecap");
   210.       put_separate_fragment_and_a_new_line("1 setlinejoin");
   211.
   212.       put_the_pen_settings;
   213.
   214.       put_separate_fragment_and_a_new_line("0 792 translate");  -- Assumes a page of length 11"!
   215.
   216.       -- The plotter step was 0.005", which is the same as 0.36 PostScript points.
   217.       -- The scaling factor is set here to make the wabbit example fit an A4 page.
   218.       put_separate_fragment_and_a_new_line("0.12 -0.12 scale");
   219.
   220.       put_separate_fragment_and_a_new_line("/l { lineto } bind def");
   221.       put_separate_fragment_and_a_new_line("/n { newpath moveto lineto } bind def");
   222.       put_separate_fragment_and_a_new_line("/s { stroke } bind def");
   223.
   224.       put_separate_fragment_and_a_new_line("save");
   225.    end initialize_PostScript_output;
   226.
   227.    procedure finalize_PostScript_output is
   228.
   229.       subtype bound_string is String(1..10);
   230.
   231.       function bound_image (n : in Natural)
   232.       return bound_string is
   233.          n_image : constant String := Natural'Image(n);
   234.          b : bound_string := (others => ' ');
   235.       begin
   236.          if n_image'Length > bound_string'Length then
   237.             raise postscript_error with "infeasible bounding box size";
   238.          else
   239.             b(b'Last-n_image'Length+b'First .. b'Last) := n_image;
   240.             return b;
   241.          end if;
   242.       end bound_image;
   243.
   244.    begin
   245.       if the_PostScript_stream_access = null then
   246.          raise postscript_error with "PostScript was already finalized";
   247.       end if;
   248.       terminate_any_open_path;
   249.       put_separate_fragment_and_a_new_line("showpage");
   250.       put_separate_fragment_and_a_new_line("restore");
   251.       put_separate_fragment_and_a_new_line("restore");
   252.       put_separate_fragment_and_a_new_line("% End of plot");
   253.
   254.       -- Go back to the bounding box placeholders in the output file.
   255.       set_position(the_position_of_the_placeholders, the_PostScript_stream_access.all);
   256.
   257.       -- Overwrite them with the actual x and y co-ordinate bounds.
   258.       put_fragment(bound_image(maximum_offset.x));
   259.       put_fragment(" ");
   260.       put_fragment(bound_image(maximum_offset.y));
   261.
   262.       close(the_PostScript_stream_access.all);
   263.       the_PostScript_stream_access := null;
   264.    exception
   265.       when others =>
   266.          close(the_PostScript_stream_access.all);
   267.          the_PostScript_stream_access := null;
   268.          raise;
   269.    end finalize_PostScript_output;
   270.
   271. end postscript;

Compiling: ../Source\postscript.ads
Source file time stamp: 2015-06-18 00:55:44
Compiled at: 2015-10-28 18:14:15

     1. -- postscript.ads
     2. --
     3. -- Elementary Encapsulated PostScript (EPS) line drawing.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with IO;
    20.
    21. package postscript is
    22.
    23.    -- Open the PostScript file and write the prelude, with a placeholder for the bounds.
    24.    procedure initialize_PostScript_output (the_GP_stream : in out IO.Stream);
    25.
    26.    -- Close the PostScript file, having gone back to overwrite the bounding box placeholders.
    27.    procedure finalize_PostScript_output;
    28.
    29.    type pen_colour is (
    30.                        Black,
    31.                        Blue,
    32.                        Brown,
    33.                        Cyan,
    34.                        Dark_Blue,
    35.                        Dark_Cyan,
    36.                        Dark_Green,
    37.                        Dark_Grey,
    38.                        Dark_Magenta,
    39.                        Dark_Red,
    40.                        Green,
    41.                        Grey,
    42.                        Magenta,
    43.                        Red,
    44.                        White,
    45.                        Yellow
    46.                       );
    47.
    48.    the_default_colour : constant pen_colour := Black;
    49.
    50.    type pen_tip_size is (
    51.                          Extra_Extra_Fine,
    52.                          Extra_Fine,
    53.                          Fine,
    54.                          Medium,
    55.                          Medium_Broad,
    56.                          Broad,
    57.                          Extra_Broad
    58.                         );
    59.
    60.    the_default_pen_tip : constant pen_tip_size := Extra_Extra_Fine;
    61.
    62.    -- Choose the pen's colour and tip size.
    63.    procedure set_the_pen_properties (this_colour  : in pen_colour   := the_default_colour;
    64.                                      this_pen_tip : in pen_tip_size := the_default_pen_tip);
    65.
    66.    -- Drawing is done in terms of the plotter's co-ordinate system.
    67.    -- (0, 0) is the top left point of the drawing,
    68.    -- The x axis increases down the plot (long axis, direction of paper movement),
    69.    --    and the y axis increases across the plot (short axis, direction of pen movement).
    70.
    71.    type point is
    72.      record
    73.         x, y : Natural;  -- All physically possible co-ordinates are non-negative.
    74.      end record;
    75.
    76.    -- Draw a straight line from initial to final.
    77.    procedure draw_a_PostScript_vector (initial, final : in postscript.point);
    78.
    79.    -- This exception is raised by:
    80.    --    untimely calls on initialize_PostScript_output and finalize_PostScript_output;
    81.    --       and by drawing at points with infeasibly large co-ordinates.
    82.    -- Before raising the exception the EPS file is finalized, if possible.
    83.
    84.    postscript_error : exception;
    85.
    86. end postscript;

 271 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\settings-io.adb
Source file time stamp: 2015-06-18 00:55:44
Compiled at: 2015-10-28 18:14:16

     1. -- settings-io.ads
     2. --
     3. -- Settings-reader I/O support.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with file_interfacing;
    20. with KDF9;
    21. with Latin_1;
    22.
    23. use  Latin_1;
    24.
    25. package body settings.IO is
    26.
    27.    pragma Unsuppress(All_Checks);
    28.
    29.    procedure open_options_file (file : in out File_Type; name : in String) is
    30.    begin
    31.       file_interfacing.initialize(file, in_file, name);
    32.       line_number := 1;
    33.    exception
    34.       when others =>
    35.          raise Status_Error with name;
    36.    end open_options_file;
    37.
    38.    procedure close_options_file (file : in out File_Type; name : in String) is
    39.    begin
    40.       file_interfacing.finalize(file, name);
    41.    end close_options_file;
    42.
    43.    comment_flag_character : constant Character := '|';
    44.
    45.    procedure skip_to_next_non_blank (file : File_Type) is
    46.       next_char : Character := ' ';
    47.       end_line  : Boolean;
    48.    begin
    49.       loop
    50.         look_ahead(file, next_char, end_line);
    51.       exit when end_line or else
    52.                   (next_char /= ' ' and next_char /= HT);
    53.          get(file, next_char);
    54.       end loop;
    55.       if next_char = comment_flag_character then
    56.          while not end_of_line(file) loop
    57.             get(file, next_char);
    58.          end loop;
    59.       end if;
    60.    end skip_to_next_non_blank;
    61.
    62.    procedure ensure_not_at_end_of_line (file : File_Type) is
    63.    begin
    64.       skip_to_next_non_blank (file);
    65.       if end_of_line(file) then
    66.          raise Data_Error;
    67.       end if;
    68.    end ensure_not_at_end_of_line;
    69.
    70.    procedure skip_to_next_nonempty_line (file : in File_Type) is
    71.       flag     : Character;
    72.       end_line : Boolean;
    73.    begin
    74.       loop
    75.          look_ahead(file, flag, end_line);
    76.          if end_line                      or else
    77.                flag = comment_flag_character then
    78.             skip_line(file);
    79.             line_number := line_number + 1;
    80.          else
    81.             exit;
    82.          end if;
    83.       end loop;
    84.       if flag = comment_flag_character then
    85.          raise Data_Error;
    86.       end if;
    87.    end skip_to_next_nonempty_line;
    88.
    89.    digit_offset : constant := Character'Pos('0');
    90.
    91.    procedure get_octal (file : in File_Type; value : out KDF9.word) is
    92.       next_char : Character;
    93.       last_char : Character := '_';
    94.       place     : Natural   := 0;
    95.       end_line  : Boolean   := False;
    96.    begin
    97.       value := 0;
    98.       ensure_not_at_end_of_line(file);
    99.       get(file, next_char);
   100.       if next_char = '#' then
   101.          get(file, next_char);
   102.       else
   103.          raise Data_Error;
   104.       end if;
   105.       loop
   106.          if next_char in '0' .. '7' then
   107.             value := value*8 + KDF9.word(Character'Pos(next_char)-digit_offset);
   108.             place := place + 1;
   109.             if place > 16 then
   110.                raise Data_Error;
   111.             end if;
   112.          elsif next_char = '_' then
   113.             if place = 0 then
   114.                raise Data_Error;
   115.             end if;
   116.          else
   117.             if last_char = '_' or place = 0 then
   118.                raise Data_Error;
   119.             end if;
   120.             exit;
   121.          end if;
   122.          last_char := next_char;
   123.          look_ahead(file, next_char, end_line);
   124.       exit when end_line;
   125.          if next_char in '0' .. '7' or next_char = '_' then
   126.             get(file, next_char);
   127.          else
   128.             if last_char = '_' or place = 0 then
   129.                raise Data_Error;
   130.             end if;
   131.             exit;
   132.          end if;
   133.       end loop;
   134.    end get_octal;
   135.
   136.    procedure get_decimal (file : in File_Type; value : out KDF9.word) is
   137.       next_char : Character;
   138.       last_char : Character := '_';
   139.       place     : Natural   := 0;
   140.       end_line  : Boolean   := False;
   141.    begin
   142.       value := 0;
   143.       ensure_not_at_end_of_line(file);
   144.       get(file, next_char);
   145.       loop
   146.          if next_char in '0' .. '9' then
   147.             value := value*10 + KDF9.word(Character'Pos(next_char)-digit_offset);
   148.             place := place + 1;
   149.             if place > 15 then
   150.                raise Data_Error;
   151.             end if;
   152.          elsif next_char = '_' then
   153.             if place = 0 then
   154.                raise Data_Error;
   155.             end if;
   156.          else
   157.             if last_char = '_' or place = 0 then
   158.                raise Data_Error;
   159.             end if;
   160.             exit;
   161.          end if;
   162.          last_char := next_char;
   163.          look_ahead(file, next_char, end_line);
   164.       exit when end_line;
   165.          if next_char in '0' .. '9' or next_char = '_' then
   166.             get(file, next_char);
   167.          else
   168.             if last_char = '_' or place = 0 then
   169.                raise Data_Error;
   170.             end if;
   171.             exit;
   172.          end if;
   173.       end loop;
   174.    end get_decimal;
   175.
   176.    procedure get_address (file : in File_Type; value : out KDF9.word) is
   177.       next_char : Character;
   178.       end_line  : Boolean;
   179.       pragma Warnings(Off, end_line);
   180.    begin
   181.       ensure_not_at_end_of_line(file);
   182.       look_ahead(file, next_char, end_line);
   183.       if next_char = '#' then
   184.          get_octal(file, value);
   185.       else
   186.          get_decimal(file, value);
   187.       end if;
   188.    end get_address;
   189.
   190. end settings.IO;
   191.

Compiling: ../Source\settings-io.ads
Source file time stamp: 2015-06-18 00:55:42
Compiled at: 2015-10-28 18:14:16

     1. -- settings-io.ads
     2. --
     3. -- Settings-reader I/O support.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Text_IO;
    20.
    21. use  Ada.Text_IO;
    22.
    23. with postscript;
    24.
    25. package settings.IO is
    26.
    27.    pragma Unsuppress(All_Checks);
    28.
    29.    line_number : Natural := 0;
    30.
    31.    procedure open_options_file (file : in out File_Type; name : in String);
    32.
    33.    procedure close_options_file (file : in out File_Type; name : in String);
    34.
    35.    -- Check that the end of the line has not yet been reached, else raise Data_Error.
    36.    procedure ensure_not_at_end_of_line (file : in File_Type);
    37.
    38.    -- Move the reading position to the next non-blank or EOL, skipping comment.
    39.    procedure skip_to_next_non_blank (file : in File_Type);
    40.
    41.    -- Discard input until a non-empty line is reached,
    42.    --    leaving the reading position at the start of that line,
    43.    --    and incrementing line_number for each line terminator passed.
    44.    procedure skip_to_next_nonempty_line (file : in File_Type);
    45.
    46.    -- Read octal digits string as KDF9.word,
    47.    --    raising Data_Error on overflow or bad syntax.
    48.    procedure get_octal (file : in File_Type; value : out KDF9.word);
    49.
    50.    -- Read decimal digits string as KDF9.word,
    51.    --    raising Data_Error on overflow or bad syntax.
    52.    procedure get_decimal (file  : in File_Type; value : out KDF9.word);
    53.
    54.    -- Read an address as a KDF9.word in either octal or decimal,
    55.    --    using get_octal or get_decimal as indicated by the syntax.
    56.    procedure get_address (file : in File_Type; value : out KDF9.word);
    57.
    58.    package colour_IO is new Ada.Text_IO.Enumeration_IO(postscript.pen_colour);
    59.    package  width_IO is new Ada.Text_IO.Enumeration_IO(postscript.pen_tip_size);
    60.
    61. end settings.IO;

 191 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\tracing.adb
Source file time stamp: 2015-06-18 00:55:26
Compiled at: 2015-10-28 18:14:16

     1. -- tracing.adb
     2. --
     3. -- Provide diagnostic trace, breakpoint, and watchpoint support.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with exceptions;
    20. with formatting;
    21. with HCI;
    22. with KDF9.compressed_opcodes;
    23. with KDF9.store;
    24. with settings;
    25. with state_display;
    26.
    27. use exceptions;
    28. use formatting;
    29. use HCI;
    30. use KDF9.compressed_opcodes;
    31. use KDF9.store;
    32. use settings;
    33. use state_display;
    34.
    35. package body tracing is
    36.
    37.    pragma Unsuppress(All_Checks);
    38.
    39.    procedure clear_all_breakpoints is
    40.    begin
    41.       is_a_breakpoint := (others => False);
    42.    end clear_all_breakpoints;
    43.
    44.    procedure set_breakpoints (first, last : in KDF9.code_location) is
    45.    begin
    46.       for p in first .. last loop
    47.          is_a_breakpoint(p) := True;
    48.       end loop;
    49.    end set_breakpoints;
    50.
    51.    procedure handle_breakpoint is
    52.    begin
    53.       short_witness;
    54.       continue_when_GO_is_pressed(caption => " at " & oct_of(NIA));
    55.       quit_if_requested;
    56.       change_diagnostic_mode_if_requested;
    57.    end handle_breakpoint;
    58.
    59.    procedure clear_all_watchpoints is
    60.    begin
    61.       for p in is_a_fetch_point'Range loop
    62.          is_a_fetch_point(p) := False;
    63.       end loop;
    64.       is_a_store_point := is_a_fetch_point;
    65.    end clear_all_watchpoints;
    66.
    67.    procedure set_fetch_points (first, last : in KDF9.address) is
    68.    begin
    69.       for p in first .. last loop
    70.          is_a_fetch_point(p) := True;
    71.       end loop;
    72.    end set_fetch_points;
    73.
    74.    procedure set_store_points (first, last : in KDF9.address) is
    75.    begin
    76.       for p in first .. last loop
    77.          is_a_store_point(p) := True;
    78.       end loop;
    79.    end set_store_points;
    80.
    81.    procedure clear_retro_FIFO is
    82.    begin
    83.       retro_FIFO_count := 0; retro_FIFO_index := 0;
    84.    end clear_retro_FIFO;
    85.
    86.    procedure take_note_of (the_IAR   : in KDF9.code_point;
    87.                            the_value : in KDF9.word) is
    88.    begin
    89.       if the_retrospective_trace_is_enabled           and then
    90.             ICR in low_count .. high_count            and then
    91.                NIA_word_number in low_bound .. high_bound then
    92.          if retro_FIFO_count = 0 then
    93.             retro_FIFO(0) := (location   => the_IAR,
    94.                               order      => INS.order,
    95.                               parameter  => the_value,
    96.                               ICR_value  => ICR,
    97.                               CPU_time   => the_CPU_time,
    98.                               nested     => the_nest_depth,
    99.                               called     => the_sjns_depth,
   100.                               V          => the_V_bit,
   101.                               T          => the_T_bit);
   102.             retro_FIFO_count := 1;
   103.          else
   104.             retro_FIFO_index := retro_FIFO_index + 1;
   105.             retro_FIFO(retro_FIFO_index) := (location => the_IAR,
   106.                                             order     => INS.order,
   107.                                             parameter => the_value,
   108.                                             ICR_value => ICR,
   109.                                             CPU_time  => the_CPU_time,
   110.                                             nested    => the_nest_depth,
   111.                                             called    => the_sjns_depth,
   112.                                             V         => the_V_bit,
   113.                                             T         => the_T_bit);
   114.             if retro_FIFO_count < FIFO_size then
   115.                retro_FIFO_count := retro_FIFO_count + 1;
   116.             end if;
   117.          end if;
   118.       end if;
   119.    end take_note_of;
   120.
   121.    procedure take_note_of (the_value : in KDF9.word) is
   122.    begin
   123.       take_note_of(CIA, the_value);
   124.    end take_note_of;
   125.
   126.    procedure clear_IOC_FIFO is
   127.    begin
   128.       IOC_FIFO_count := 0; IOC_FIFO_index := 0;
   129.    end clear_IOC_FIFO;
   130.
   131.    procedure take_note_of
   132.          (
   133.           kind            : in IOC_event_kind;
   134.           ICR_value       : in KDF9.order_counter;
   135.           order_address   : in KDF9.code_point;
   136.           decoded_order   : in KDF9.decoded_order;
   137.           initiation_time : in KDF9.microseconds;
   138.           device_name     : in KDF9.logical_device_name;
   139.           completion_time : in KDF9.microseconds := 0;
   140.           is_for_Director : in Boolean := False;
   141.           priority_level  : in KDF9.priority := 0;
   142.           control_word    : in KDF9.Q_register := (0, 0, 0)
   143.          ) is
   144.
   145.       function the_note
   146.       return IOC_FIFO_entry is
   147.       begin
   148.          case take_note_of.kind is
   149.             when start_transfer =>
   150.                return (
   151.                        kind            => start_transfer,
   152.                        ICR_value       => take_note_of.ICR_value,
   153.                        order_address   => take_note_of.order_address,
   154.                        decoded_order   => take_note_of.decoded_order,
   155.                        initiation_time => take_note_of.initiation_time,
   156.                        completion_time => take_note_of.completion_time,
   157.                        is_for_Director => take_note_of.is_for_Director,
   158.                        priority_level  => take_note_of.priority_level,
   159.                        control_word    => take_note_of.control_word,
   160.                        device_name     => take_note_of.device_name
   161.                       );
   162.             when finis_transfer =>
   163.                return (
   164.                        kind            => finis_transfer,
   165.                        ICR_value       => take_note_of.ICR_value,
   166.                        order_address   => take_note_of.order_address,
   167.                        decoded_order   => take_note_of.decoded_order,
   168.                        initiation_time => take_note_of.initiation_time,
   169.                        completion_time => take_note_of.completion_time,
   170.                        is_for_Director => take_note_of.is_for_Director,
   171.                        priority_level  => take_note_of.priority_level,
   172.                        control_word    => take_note_of.control_word,
   173.                        device_name     => take_note_of.device_name
   174.                       );
   175.             when store_lockout =>
   176.                return (
   177.                        kind            => store_lockout,
   178.                        ICR_value       => take_note_of.ICR_value,
   179.                        order_address   => take_note_of.order_address,
   180.                        decoded_order   => take_note_of.decoded_order,
   181.                        initiation_time => take_note_of.initiation_time,
   182.                        data_address    => the_locked_out_address,
   183.                        device_name     => take_note_of.device_name
   184.                       );
   185.             when buffer_lockout =>
   186.                return (
   187.                        kind             => buffer_lockout,
   188.                        ICR_value        => take_note_of.ICR_value,
   189.                        order_address    => take_note_of.order_address,
   190.                        decoded_order    => take_note_of.decoded_order,
   191.                        initiation_time  => take_note_of.initiation_time,
   192.                        device_name      => take_note_of.device_name
   193.                       );
   194.             when test_buffer_status =>
   195.                raise emulation_failure with "in the_note";
   196.          end case;
   197.       end the_note;
   198.
   199.    begin
   200.       if the_peripheral_trace_is_enabled              and then
   201.             ICR in low_count .. high_count            and then
   202.                NIA_word_number in low_bound .. high_bound then
   203.          if IOC_FIFO_count = 0 then
   204.             IOC_FIFO(0) := the_note;
   205.             IOC_FIFO_count := 1;
   206.          else
   207.             IOC_FIFO_index := IOC_FIFO_index + 1;
   208.             IOC_FIFO(IOC_FIFO_index) := the_note;
   209.             if IOC_FIFO_count < FIFO_size then
   210.                IOC_FIFO_count := IOC_FIFO_count + 1;
   211.             end if;
   212.          end if;
   213.       end if;
   214.    end take_note_of;
   215.
   216.    procedure take_note_of
   217.          (
   218.           Q_register  : in KDF9.Q_register;
   219.           device_name : in KDF9.logical_device_name := "   ";
   220.           status      : in KDF9.word := KDF9.word'Last
   221.          ) is
   222.
   223.       function the_note
   224.       return IOC_FIFO_entry is
   225.       begin
   226.          return (
   227.                  kind            => test_buffer_status,
   228.                  ICR_value       => ICR+1,  -- ICR is not incremented until the end of an order.
   229.                  order_address   => CIA,
   230.                  decoded_order   => INS,
   231.                  initiation_time => the_clock_time,
   232.                  device_name     => take_note_of.device_name,
   233.                  Q_register      => take_note_of.Q_register,
   234.                  status          => take_note_of.status
   235.                 );
   236.       end the_note;
   237.
   238.    begin
   239.       if the_peripheral_trace_is_enabled              and then
   240.             ICR in low_count .. high_count            and then
   241.                NIA_word_number in low_bound .. high_bound then
   242.          if IOC_FIFO_count = 0 then
   243.             IOC_FIFO(0) := the_note;
   244.             IOC_FIFO_count := 1;
   245.          else
   246.             IOC_FIFO_index := IOC_FIFO_index + 1;
   247.             IOC_FIFO(IOC_FIFO_index) := the_note;
   248.             if IOC_FIFO_count < FIFO_size then
   249.                IOC_FIFO_count := IOC_FIFO_count + 1;
   250.             end if;
   251.          end if;
   252.       end if;
   253.    end take_note_of;
   254.
   255.
   256.    procedure clear_interrupt_FIFO is
   257.    begin
   258.       interrupt_FIFO_count := 0; interrupt_FIFO_index := 0;
   259.    end clear_interrupt_FIFO;
   260.
   261.    procedure take_note_of
   262.          (
   263.           interrupt_code : in KDF9.interrupt_number;
   264.           ICR_value      : in KDF9.order_counter;
   265.           order_address  : in KDF9.code_point;
   266.           busy_time      : in KDF9.microseconds;
   267.           in_Director    : in Boolean := False;
   268.           priority_level : in KDF9.priority
   269.          ) is
   270.
   271.       function the_note
   272.       return interrupt_FIFO_entry is
   273.       begin
   274.          return (
   275.                  interrupt_code => take_note_of.interrupt_code,
   276.                  ICR_value      => take_note_of.ICR_value,
   277.                  order_address  => take_note_of.order_address,
   278.                  busy_time      => take_note_of.busy_time,
   279.                  in_Director    => take_note_of.in_Director,
   280.                  priority_level => take_note_of.priority_level
   281.                 );
   282.       end the_note;
   283.
   284.    begin
   285.       if the_interrupt_trace_is_enabled               and then
   286.             ICR in low_count .. high_count            and then
   287.                NIA_word_number in low_bound .. high_bound then
   288.          if interrupt_FIFO_count = 0 then
   289.             interrupt_FIFO(0) := the_note;
   290.             interrupt_FIFO_count := 1;
   291.          else
   292.             interrupt_FIFO_index := interrupt_FIFO_index + 1;
   293.             interrupt_FIFO(interrupt_FIFO_index) := the_note;
   294.             if interrupt_FIFO_count < FIFO_size then
   295.                interrupt_FIFO_count := interrupt_FIFO_count + 1;
   296.             end if;
   297.          end if;
   298.       end if;
   299.    end take_note_of;
   300.
   301.    procedure add_INS_to_the_histogram is
   302.       syllable_0 : KDF9.syllable := INS.order.syllable_0;
   303.    begin
   304.       if INS.kind = normal_jump_order then
   305.          syllable_0 := (syllable_0 and 2#1111_0000#) or INS.Qq;
   306.       elsif INS.kind = data_access_order then
   307.          syllable_0 := (syllable_0 and 2#11_000_111#);
   308.       end if;
   309.       the_histogram(syllable_0) := the_histogram(syllable_0) + 1;
   310.    end add_INS_to_the_histogram;
   311.
   312.    procedure preview_a_one_syllable_order is
   313.    begin
   314.       null;
   315.    end preview_a_one_syllable_order;
   316.
   317.    procedure preview_a_two_syllable_order is
   318.    begin
   319.       case INS.syndrome is
   320.          when TO_MkMq
   321.             | TO_MkMqQ
   322.             | TO_MkMqH
   323.             | TO_MkMqQH
   324.             | TO_MkMqN
   325.             | TO_MkMqQN
   326.             | TO_MkMqHN
   327.             | TO_MkMqQHN =>
   328.             the_trace_operand := read_top;
   329.          when others =>
   330.             the_trace_operand := as_word(the_Q_store(INS.Qq));
   331.       end case;
   332.    end preview_a_two_syllable_order;
   333.
   334.    procedure preview_a_jump_order is
   335.    begin
   336.       case INS.syndrome is
   337.          when JrEQ
   338.             | JrNE
   339.             | JrGTZ
   340.             | JrLTZ
   341.             | JrEQZ
   342.             | JrLEZ
   343.             | JrGEZ
   344.             | JrNEZ
   345.             | OUT_9 =>
   346.             if the_nest_depth > 0 then
   347.                the_trace_operand := read_top;
   348.             end if;
   349.          when JrV
   350.             | JrNV =>
   351.             the_trace_operand := the_V_bit;
   352.          when JrEN
   353.             | JrNEN =>
   354.             the_trace_operand := KDF9.word(the_nest_depth);
   355.          when JrEJ
   356.             | JrNEJ =>
   357.             the_trace_operand := KDF9.word(the_sjns_depth);
   358.          when JrTR
   359.             | JrNTR =>
   360.             the_trace_operand := the_T_bit;
   361.          when EXIT_9
   362.             | EXITD =>
   363.             if the_sjns_depth > 0 then
   364.                the_trace_operand := as_word(sjns_top);
   365.             end if;
   366.          when JrCqZ
   367.             | JrCqNZ =>
   368.             the_trace_operand := as_word(the_Q_store(INS.Qq));
   369.          when others =>
   370.             null;
   371.       end case;
   372.    end preview_a_jump_order;
   373.
   374.    procedure preview_a_data_access_order is
   375.    begin
   376.       case INS.syndrome is
   377.          when TO_EaMq
   378.             | TO_EaMqQ =>
   379.             the_trace_operand := read_top;
   380.          when others =>
   381.             null;
   382.       end case;
   383.    end preview_a_data_access_order;
   384.
   385.    procedure look_back_at_a_one_syllable_order is
   386.       AB : KDF9.pair;
   387.    begin
   388.       case INS.syndrome is
   389.          when TO_TR =>
   390.             the_trace_operand := the_T_bit;
   391.          when XDF
   392.             | XPLUSF
   393.             | MINUSDF
   394.             | PLUSDF
   395.             | FLOATD
   396.             | NEGDF
   397.             | MAXF
   398.             | PERM
   399.             | CAB
   400.             | MAX
   401.             | XD
   402.             | NEGD
   403.             | DUPD
   404.             | DIVI
   405.             | STR
   406.             | REVD
   407.             | MINUSD
   408.             | PLUSD
   409.             | DIVR =>
   410.             AB := read_top;
   411.             the_trace_operand := AB.msw;
   412.          when others =>
   413.             if the_nest_depth > 0 then
   414.                the_trace_operand := read_top;
   415.             end if;
   416.       end case;
   417.    end look_back_at_a_one_syllable_order;
   418.
   419.    procedure look_back_at_an_IO_order is
   420.    begin
   421.       null;
   422.    end look_back_at_an_IO_order;
   423.
   424.    procedure look_back_at_a_two_syllable_order is
   425.       AB : KDF9.pair;
   426.    begin
   427.       case INS.syndrome is
   428.          when MkMq
   429.             | MkMqQ
   430.             | MkMqH
   431.             | MkMqQH
   432.             | MkMqQN
   433.             | MkMqHN
   434.             | MkMqQHN
   435.             | QCIMq
   436.             | SHA
   437.             | SHL
   438.             | SHC
   439.             | TO_Kk
   440.             | Kk
   441.             | LINK =>
   442.             the_trace_operand := read_top;
   443.          when TO_MkMq
   444.             | TO_MkMqQ
   445.             | TO_MkMqH
   446.             | TO_MkMqQH
   447.             | TO_MkMqN
   448.             | TO_MkMqQN
   449.             | TO_MkMqHN
   450.             | TO_MkMqQHN =>
   451.             null;
   452.          when M_PLUS_Iq
   453.             | M_MINUS_Iq
   454.             | NCq
   455.             | DCq
   456.             | POS1_TO_Iq
   457.             | NEG1_TO_Iq
   458.             | POS2_TO_Iq
   459.             | NEG2_TO_Iq
   460.             | TO_RCIMq
   461.             | ADD_TO_QCIMq
   462.             | JCqNZS =>
   463.             the_trace_operand := as_word(the_Q_store(INS.Qq));
   464.          when CqTOQk
   465.             | IqTOQk
   466.             | MqTOQk
   467.             | QqTOQk
   468.             | CIqTOQk
   469.             | IMqTOQk
   470.             | CMqTOQk =>
   471.             the_trace_operand := as_word(the_Q_store(INS.Qk));
   472.          when SHLD
   473.             | SHAD
   474.             | MACC =>
   475.             AB := read_top;
   476.             the_trace_operand := AB.msw;
   477.          when TO_LINK =>
   478.             the_trace_operand := as_word(sjns_top);
   479.          when others =>
   480.             look_back_at_an_IO_order;
   481.       end case;
   482.    end look_back_at_a_two_syllable_order;
   483.
   484.    procedure look_back_at_a_jump_order is
   485.    begin
   486.       case INS.syndrome is
   487.          when Jr =>
   488.             the_trace_operand := as_word(code_link(NIA));
   489.          when JSr =>
   490.             the_trace_operand := as_word(sjns_top);
   491.          when others =>
   492.             null;
   493.       end case;
   494.    end look_back_at_a_jump_order;
   495.
   496.    procedure look_back_at_a_data_access_order is
   497.    begin
   498.       case INS.syndrome is
   499.          when EaMq
   500.             | EaMqQ
   501.             | SET =>
   502.             the_trace_operand := read_top;
   503.          when others =>
   504.             null;
   505.       end case;
   506.    end look_back_at_a_data_access_order;
   507.
   508.    procedure act_on_any_fetchpoint is
   509.       use type watch_flags.set;
   510.    begin
   511.       if the_trace_address / is_a_fetch_point then
   512.          log_new_line;
   513.          log("Fetch watchhpoint: N1 := [#");
   514.          log(oct_of(the_trace_address));
   515.          log("]");
   516.          short_witness;
   517.          continue_when_GO_is_pressed;
   518.          quit_if_requested;
   519.          change_diagnostic_mode_if_requested;
   520.       end if;
   521.    end act_on_any_fetchpoint;
   522.
   523.    procedure act_on_any_storepoint is
   524.       use type watch_flags.set;
   525.    begin
   526.       if the_trace_address / is_a_store_point then
   527.          log_new_line;
   528.          log("Store watchpoint: #");
   529.          log(oct_of(the_trace_address));
   530.          log(" := [N1] = #");
   531.          log(oct_of(the_trace_operand));
   532.          short_witness;
   533.          continue_when_GO_is_pressed;
   534.          quit_if_requested;
   535.          change_diagnostic_mode_if_requested;
   536.       end if;
   537.    end act_on_any_storepoint;
   538.
   539.    procedure act_on_any_two_syllable_order_watchpoints is
   540.    begin
   541.       case INS.syndrome is
   542.          when MkMq
   543.             | MkMqQ
   544.             | MkMqH
   545.             | MkMqQH
   546.             | MkMqQN
   547.             | MkMqHN
   548.             | MkMqQHN =>
   549.             act_on_any_fetchpoint;
   550.          when TO_MkMq
   551.             | TO_MkMqQ
   552.             | TO_MkMqH
   553.             | TO_MkMqQH
   554.             | TO_MkMqN
   555.             | TO_MkMqQN
   556.             | TO_MkMqHN
   557.             | TO_MkMqQHN =>
   558.             act_on_any_storepoint;
   559.          when others =>
   560.             null;
   561.       end case;
   562.    end act_on_any_two_syllable_order_watchpoints;
   563.
   564.    procedure act_on_any_data_access_order_watchpoints is
   565.    begin
   566.       case INS.syndrome is
   567.          when EaMq
   568.             | EaMqQ =>
   569.             act_on_any_fetchpoint;
   570.          when TO_EaMq
   571.             | TO_EaMqQ =>
   572.             act_on_any_storepoint;
   573.          when others =>
   574.             null;
   575.       end case;
   576.    end act_on_any_data_access_order_watchpoints;
   577.
   578. end tracing;

Compiling: ../Source\tracing.ads
Source file time stamp: 2015-06-18 00:55:24
Compiled at: 2015-10-28 18:14:16

     1. -- tracing.ads
     2. --
     3. -- Provide diagnostic trace, breakpoint, and watchpoint support.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9;
    20. with generic_sets; pragma Elaborate_All(generic_sets);
    21.
    22. use  KDF9;
    23.
    24. package tracing is
    25.
    26.    pragma Unsuppress(All_Checks);
    27.
    28.    -- Support for significant-operand evaluation and tracing.
    29.
    30.    the_trace_operand : KDF9.word;
    31.    the_trace_address : KDF9.address;
    32.
    33.    procedure preview_a_one_syllable_order;
    34.
    35.    procedure preview_a_two_syllable_order;
    36.
    37.    procedure preview_a_jump_order;
    38.
    39.    procedure preview_a_data_access_order;
    40.
    41.    procedure look_back_at_a_one_syllable_order;
    42.
    43.    procedure look_back_at_a_two_syllable_order;
    44.
    45.    procedure look_back_at_a_jump_order;
    46.
    47.    procedure look_back_at_a_data_access_order;
    48.
    49.    -- Support for breakpoints.
    50.
    51.    package order_flags is new generic_sets(member => KDF9.code_location);
    52.
    53.    is_a_breakpoint : order_flags.set := order_flags.empty_set;
    54.
    55.    procedure clear_all_breakpoints;
    56.
    57.    procedure set_breakpoints (first, last : in KDF9.code_location);
    58.
    59.    procedure handle_breakpoint;
    60.
    61.    -- Support for watchpoints.
    62.
    63.    package watch_flags is new generic_sets(member => KDF9.address);
    64.
    65.    is_a_fetch_point : watch_flags.set := watch_flags.empty_set;
    66.    is_a_store_point : watch_flags.set := watch_flags.empty_set;
    67.
    68.    procedure clear_all_watchpoints;
    69.
    70.    procedure set_fetch_points (first, last : in KDF9.address);
    71.
    72.    procedure set_store_points (first, last : in KDF9.address);
    73.
    74.    -- These two procedures must NOT be called in fast_mode.
    75.
    76.    procedure act_on_any_two_syllable_order_watchpoints;
    77.
    78.    procedure act_on_any_data_access_order_watchpoints;
    79.
    80.
    81.    --
    82.    -- Retrospective tracing.
    83.    --
    84.
    85.    FIFO_size : constant := 256;
    86.
    87.    type FIFO_index is mod FIFO_size;
    88.
    89.    -- Support for all-instruction retrospective tracing.
    90.
    91.    type retro_FIFO_entry is
    92.       record
    93.          location  : KDF9.code_point := (0, 0);
    94.          order     : KDF9.syllable_group := (0, 0, 0);
    95.          parameter : KDF9.word := 0;
    96.          ICR_value : KDF9.order_counter := 0;
    97.          CPU_time  : KDF9.microseconds := 0;
    98.          nested    : KDF9.nest_depth := 0;
    99.          called    : KDF9.sjns_depth := 0;
   100.          V, T      : KDF9.word := 0;
   101.       end record;
   102.
   103.    retro_FIFO  : array (tracing.FIFO_index) of tracing.retro_FIFO_entry;
   104.
   105.    retro_FIFO_index : tracing.FIFO_index := 0;
   106.
   107.    retro_FIFO_count : Natural range 0 .. FIFO_size := 0;
   108.
   109.    procedure clear_retro_FIFO;
   110.
   111.    procedure take_note_of (the_value : in KDF9.word);
   112.
   113.    -- Support for retrospective peripheral I/O tracing.
   114.
   115.    type IOC_event_kind is (start_transfer, finis_transfer,
   116.                            store_lockout, buffer_lockout,
   117.                            test_buffer_status);
   118.
   119.    type IOC_FIFO_entry (kind : IOC_event_kind := start_transfer) is
   120.       record
   121.          ICR_value       : KDF9.order_counter := 0;
   122.          order_address   : KDF9.code_point := (0, 0);
   123.          decoded_order   : KDF9.decoded_order;
   124.          initiation_time : KDF9.microseconds := 0;
   125.          device_name     : KDF9.logical_device_name;
   126.          case kind is
   127.             when start_transfer | finis_transfer =>
   128.                completion_time : KDF9.microseconds := 0;
   129.                is_for_Director : Boolean := False;
   130.                priority_level  : KDF9.priority := 0;
   131.                control_word    : KDF9.Q_register := (0, 0, 0);
   132.             when store_lockout =>
   133.                data_address : KDF9.Q_part := 0;
   134.             when buffer_lockout =>
   135.                null;
   136.             when test_buffer_status =>
   137.                Q_register : KDF9.Q_register := (0, 0, 0);
   138.                status : KDF9.word := 0;
   139.          end case;
   140.       end record;
   141.
   142.    IOC_FIFO  : array (tracing.FIFO_index) of tracing.IOC_FIFO_entry;
   143.
   144.    IOC_FIFO_index : tracing.FIFO_index := 0;
   145.
   146.    IOC_FIFO_count : Natural range 0 .. FIFO_size := 0;
   147.
   148.    procedure clear_IOC_FIFO;
   149.
   150.    procedure take_note_of (
   151.                            kind            : in IOC_event_kind;
   152.                            ICR_value       : in KDF9.order_counter;
   153.                            order_address   : in KDF9.code_point;
   154.                            decoded_order   : in KDF9.decoded_order;
   155.                            initiation_time : in KDF9.microseconds;
   156.                            device_name     : in KDF9.logical_device_name;
   157.                            completion_time : in KDF9.microseconds := 0;
   158.                            is_for_Director : in Boolean := False;
   159.                            priority_level  : in KDF9.priority := 0;
   160.                            control_word    : in KDF9.Q_register := (0, 0, 0)
   161.                           );
   162.
   163.    procedure take_note_of (
   164.                            Q_register      : in KDF9.Q_register;
   165.                            device_name     : in KDF9.logical_device_name := "   ";
   166.                            status          : in KDF9.word := KDF9.word'Last
   167.                           );
   168.
   169.    -- Support for retrospective interrupt-request tracing.
   170.
   171.    type interrupt_FIFO_entry is
   172.       record
   173.          interrupt_code  : KDF9.interrupt_number := RESET_flag;
   174.          ICR_value       : KDF9.order_counter := 0;
   175.          order_address   : KDF9.code_point := (0, 0);
   176.          busy_time       : KDF9.microseconds := 0;
   177.          in_Director     : Boolean := False;
   178.          priority_level  : KDF9.priority := 0;
   179.       end record;
   180.
   181.    interrupt_FIFO  : array (tracing.FIFO_index) of tracing.interrupt_FIFO_entry;
   182.
   183.    interrupt_FIFO_index : tracing.FIFO_index := 0;
   184.
   185.    interrupt_FIFO_count : Natural range 0 .. FIFO_size := 0;
   186.
   187.    procedure clear_interrupt_FIFO;
   188.
   189.    procedure take_note_of (
   190.                            interrupt_code  : in KDF9.interrupt_number;
   191.                            ICR_value       : in KDF9.order_counter;
   192.                            order_address   : in KDF9.code_point;
   193.                            busy_time       : in KDF9.microseconds;
   194.                            in_Director     : in Boolean := False;
   195.                            priority_level  : in KDF9.priority
   196.                           );
   197.
   198.    -- Support for the instruction-type frequency histogram.
   199.
   200.    type histogram is array (KDF9.syllable) of KDF9.order_counter;
   201.
   202.    nul_histogram : constant histogram := (others => 0);
   203.
   204.    the_histogram : histogram := nul_histogram;
   205.
   206.    procedure add_INS_to_the_histogram;
   207.
   208. end tracing;

 578 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-two_shift-gp.adb
Source file time stamp: 2015-06-18 00:56:22
Compiled at: 2015-10-28 18:14:19

     1. -- ioc-shift_devices-gp.ads
     2. --
     3. -- Emulation of a Calcomp 564 graph plotter, switched to a tape punch buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Exceptions;
    20. --
    21. with formatting;
    22. with IO; pragma Unreferenced(IO);
    23. with IOC; pragma Elaborate_All(IOC);
    24. with IOC.two_shift;
    25. with KDF9.store;
    26. with plotter; pragma Elaborate_All(plotter);
    27. with POSIX; pragma Unreferenced(POSIX);
    28. with postscript; pragma Elaborate_All(postscript);
    29. with settings;
    30.
    31. use  KDF9.store;
    32. use  formatting;
    33. use  plotter;
    34. use  postscript;
    35. use  settings;
    36.
    37. package body IOC.two_shift.GP is
    38.
    39.    pragma Unsuppress(All_Checks);
    40.
    41.    overriding
    42.    procedure Initialize (the_GP : in out GP.device) is
    43.    begin
    44.       if the_graph_plotter_is_configured then
    45.          -- Switch the buffer to the graph plotter.
    46.          open(the_GP, write_mode, attaching => False);
    47.          if the_GP.is_open then
    48.             initialize_PostScript_output(the_GP.stream);
    49.             open_the_plot_file;
    50.          end if;
    51.       end if;
    52.    end Initialize;
    53.
    54.    overriding
    55.    procedure Finalize (the_GP : in out GP.device) is
    56.    begin
    57.       if the_graph_plotter_is_configured then
    58.          if the_GP.is_open         and then
    59.                the_GP.byte_count /= 0  then
    60.             if the_final_state_is_wanted then
    61.                output_line(the_GP.device_name
    62.                          & " on buffer #"
    63.                          & oct_of(KDF9.Q_part(the_GP.number), 2)
    64.                          & " plotted"
    65.                          & KDF9.word'Image(the_GP.byte_count)
    66.                          & " character(s).");
    67.             end if;
    68.             the_GP.byte_count := 0;
    69.             close_the_plot_file;
    70.             finalize_PostScript_output;
    71.          end if;
    72.       end if;
    73.    end Finalize;
    74.
    75.    -- the_T_bit := (the punch buffer is switched to a graph plotter);
    76.    overriding
    77.    procedure PMB (the_GP      : in out GP.device;
    78.                   Q_operand   : in KDF9.Q_register;
    79.                   set_offline : in Boolean) is
    80.       pragma Unreferenced(set_offline);
    81.    begin
    82.       validate_device(the_GP, Q_operand);
    83.       validate_parity(the_GP);
    84.       the_T_bit := 1;
    85.       take_note_of(Q_operand, the_GP.device_name, the_T_bit);
    86.    end PMB;
    87.
    88.    GP_quantum   : constant := 1E6 / 200;  -- 200 plotting movements per second.
    89.    GP_lift_time : constant := 1E6 /  10;  --  10 pen up/down movements per second.
    90.    lift_ratio   : constant := GP_lift_time / GP_quantum;
    91.
    92.    overriding
    93.    procedure do_output_housekeeping (the_GP      : in out GP.device;
    94.                                      size, lifts : in     KDF9.word) is
    95.    begin
    96.       add_in_the_IO_CPU_time(the_GP, size);
    97.       correct_transfer_time(the_GP, size - lifts + lifts * lift_ratio);
    98.    end do_output_housekeeping;
    99.
   100.    function command_in_octal (symbol : plotter.command) return String is
   101.    begin
   102.       return oct_of(KDF9.word(symbol))(15..16);
   103.    end command_in_octal;
   104.
   105.    procedure put_symbols (the_GP    : in out GP.device;
   106.                           Q_operand : in KDF9.Q_register) is
   107.       start_address : constant KDF9.address := Q_operand.I;
   108.       end_address   : constant KDF9.address := Q_operand.M;
   109.       size    : KDF9.word := 0;
   110.       lifts   : KDF9.word := 0;
   111.       symbol  : plotter.command;
   112.    begin
   113.       validate_range_access(start_address, end_address);
   114.    word_loop:
   115.       for w in start_address .. end_address loop
   116.          for c in KDF9.symbol_number'Range loop
   117.             symbol := plotter.command(fetch_symbol(w, c));
   118.             if is_valid(symbol) then
   119.                perform(symbol);
   120.                size := size + 1;
   121.                the_GP.byte_count := the_GP.byte_count + 1;
   122.                if symbol = pen_up or symbol = pen_down then
   123.                   -- These actions are much slower than plotting movements.
   124.                   lifts := lifts + 1;
   125.                end if;
   126.             else
   127.                do_output_housekeeping (the_GP, size, lifts);
   128.                trap_invalid_instruction("invalid plot command: #" & command_in_octal(symbol));
   129.             end if;
   130.          end loop;
   131.       end loop word_loop;
   132.       do_output_housekeeping (the_GP, size, lifts);
   133.    end put_symbols;
   134.
   135.    overriding
   136.    procedure POA (the_GP      : in out GP.device;
   137.                   Q_operand   : in KDF9.Q_register;
   138.                   set_offline : in Boolean) is
   139.    begin
   140.       initialize_byte_mode_transfer(the_GP, Q_operand, set_offline);
   141.       put_symbols(the_GP, Q_operand);
   142.       set_lockouts(Q_operand);
   143.    end POA;
   144.
   145.    overriding
   146.    procedure POB (the_GP      : in out GP.device;
   147.                   Q_operand   : in KDF9.Q_register;
   148.                   set_offline : in Boolean) is
   149.    begin
   150.       -- See the Manual Appendix 6, §5.2, p.303.
   151.       POA(the_GP, Q_operand, set_offline);
   152.    end POB;
   153.
   154.    procedure put_words (the_GP    : in out GP.device;
   155.                         Q_operand : in KDF9.Q_register) is
   156.       start_address : constant KDF9.address := Q_operand.I;
   157.       end_address   : constant KDF9.address := Q_operand.M;
   158.       size    : KDF9.word := 0;
   159.       lifts   : KDF9.word := 0;
   160.       symbol  : plotter.command;
   161.    begin
   162.       validate_range_access(start_address, end_address);
   163.       for w in start_address .. end_address loop
   164.          -- Ony the last 6 bits (character 7) of each word are used.
   165.          symbol := plotter.command(fetch_symbol(w, 7));
   166.          if is_valid(symbol) then
   167.             perform(symbol);
   168.             size := size + 1;
   169.             the_GP.byte_count := the_GP.byte_count + 1;
   170.             if symbol = pen_up or symbol = pen_down then
   171.                -- These actions are much slower than plotting movements.
   172.                lifts := lifts + 1;
   173.             end if;
   174.          else
   175.             do_output_housekeeping (the_GP, size, lifts);
   176.             trap_invalid_instruction("invalid plot command: #" & command_in_octal(symbol));
   177.          end if;
   178.       end loop;
   179.       do_output_housekeeping (the_GP, size, lifts);
   180.    end put_words;
   181.
   182.    overriding
   183.    procedure POC (the_GP      : in out GP.device;
   184.                   Q_operand   : in KDF9.Q_register;
   185.                   set_offline : in Boolean) is
   186.    begin
   187.       initialize_byte_mode_transfer(the_GP, Q_operand, set_offline);
   188.       put_words(the_GP, Q_operand);
   189.       set_lockouts(Q_operand);
   190.    end POC;
   191.
   192.    overriding
   193.    procedure POD (the_GP      : in out GP.device;
   194.                   Q_operand   : in KDF9.Q_register;
   195.                   set_offline : in Boolean) is
   196.    begin
   197.       -- See the Manual Appendix 6, §5.2, p.303.
   198.       POC(the_GP, Q_operand, set_offline);
   199.    end POD;
   200.
   201.    GP0 : aliased GP.device (GP0_number,
   202.                             kind    => GP_kind,
   203.                             unit    => 0,
   204.                             quantum => GP_quantum,
   205.                             is_slow => True);
   206.
   207.    procedure switch_the_shared_buffer_onto_GP0 is
   208.    begin
   209.       Initialize(GP0);
   210.    end switch_the_shared_buffer_onto_GP0;
   211.
   212. end IOC.two_shift.GP;

Compiling: ../Source\ioc-two_shift-gp.ads
Source file time stamp: 2015-06-18 00:56:22
Compiled at: 2015-10-28 18:14:19

     1. -- ioc-shift_devices-gp.ads
     2. --
     3. -- Emulation of a Calcomp 564 graph plotter, switched to a tape punch buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package IOC.two_shift.GP is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    type device is new IOC.two_shift.device with private;
    24.
    25.    overriding
    26.    procedure POA (the_GP      : in out GP.device;
    27.                   Q_operand   : in KDF9.Q_register;
    28.                   set_offline : in Boolean);
    29.    overriding
    30.    procedure POB (the_GP      : in out GP.device;
    31.                   Q_operand   : in KDF9.Q_register;
    32.                   set_offline : in Boolean);
    33.    overriding
    34.    procedure POC (the_GP      : in out GP.device;
    35.                   Q_operand   : in KDF9.Q_register;
    36.                   set_offline : in Boolean);
    37.    overriding
    38.    procedure POD (the_GP      : in out GP.device;
    39.                   Q_operand   : in KDF9.Q_register;
    40.                   set_offline : in Boolean);
    41.
    42.    -- TR := (buffer is switched to graph plotter)
    43.    overriding
    44.    procedure PMB (the_GP      : in out GP.device;
    45.                   Q_operand   : in KDF9.Q_register;
    46.                   set_offline : in Boolean);
    47.
    48.    procedure switch_the_shared_buffer_onto_GP0;
    49.
    50. private
    51.
    52.    type device is new IOC.two_shift.device with null record;
    53.
    54.    overriding
    55.    procedure Initialize (the_GP : in out GP.device);
    56.
    57.    overriding
    58.    procedure Finalize (the_GP : in out GP.device);
    59.
    60.    overriding
    61.    procedure do_output_housekeeping (the_GP      : in out GP.device;
    62.                                     size, lifts : in     KDF9.word);
    63.
    64. end IOC.two_shift.GP;

 212 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-two_shift-tp.adb
Source file time stamp: 2015-06-18 00:56:20
Compiled at: 2015-10-28 18:14:21

     1. -- ioc-shift_devices-tp.ads
     2. --
     3. -- Emulation of a tape punch buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with IO; pragma Unreferenced(IO);
    20. with IOC; pragma Elaborate_All(IOC);
    21. with IOC.two_shift;
    22. with KDF9.store;
    23. with POSIX; pragma Unreferenced(POSIX);
    24. with settings;
    25.
    26. use  KDF9.store;
    27. use  settings;
    28.
    29. package body IOC.two_shift.TP is
    30.
    31.    pragma Unsuppress(All_Checks);
    32.
    33.    overriding
    34.    procedure Initialize (the_TP : in out TP.device) is
    35.    begin
    36.       if the_TP.unit = 0 then
    37.          -- Use the emulator's standard output.
    38.          open(the_TP, write_mode, attaching => True, to_fd => 1);
    39.       else
    40.          if the_graph_plotter_is_configured then return; end if;
    41.          -- We are not plotting, so switch the buffer to the tape punch.
    42.          open(the_TP, write_mode, attaching => False);
    43.       end if;
    44.       the_TP.current_case := KDF9.Case_Normal;
    45.    end Initialize;
    46.
    47.    overriding
    48.    procedure Finalize (the_TP : in out TP.device) is
    49.    begin
    50.       close(the_TP, "punched", the_TP.byte_count, "character(s)");
    51.    end Finalize;
    52.
    53.
    54.    -- TR := (the buffer has been switched from a tape punch to a graph plotter)
    55.    overriding
    56.    procedure PMB (the_TP      : in out TP.device;
    57.                   Q_operand   : in KDF9.Q_register;
    58.                   set_offline : in Boolean) is
    59.       pragma Unreferenced(set_offline);
    60.    begin
    61.       validate_device(the_TP, Q_operand);
    62.       validate_parity(the_TP);
    63.       the_T_bit := Boolean'Pos(the_graph_plotter_is_configured);
    64.       take_note_of(Q_operand, the_TP.device_name, the_T_bit);
    65.    end PMB;
    66.
    67.    -- PWQq
    68.    overriding
    69.    procedure POA (the_TP      : in out TP.device;
    70.                   Q_operand   : in KDF9.Q_register;
    71.                   set_offline : in Boolean) is
    72.    begin
    73.       initialize_byte_mode_transfer(the_TP, Q_operand, set_offline);
    74.       write(the_TP, Q_operand);
    75.       set_lockouts(Q_operand);
    76.    end POA;
    77.
    78.    -- PWEQq
    79.    overriding
    80.    procedure POB (the_TP      : in out TP.device;
    81.                   Q_operand   : in KDF9.Q_register;
    82.                   set_offline : in Boolean) is
    83.    begin
    84.       initialize_byte_mode_transfer(the_TP, Q_operand, set_offline);
    85.       write_to_EM(the_TP, Q_operand);
    86.       set_lockouts(Q_operand);
    87.    end POB;
    88.
    89.    -- PWCQq
    90.    overriding
    91.    procedure POC (the_TP      : in out TP.device;
    92.                   Q_operand   : in KDF9.Q_register;
    93.                   set_offline : in Boolean) is
    94.    begin
    95.       initialize_byte_mode_transfer(the_TP, Q_operand, set_offline);
    96.       words_write(the_TP, Q_operand);
    97.       set_lockouts(Q_operand);
    98.    end POC;
    99.
   100.    -- PWCEQq
   101.    overriding
   102.    procedure POD (the_TP      : in out TP.device;
   103.                   Q_operand   : in KDF9.Q_register;
   104.                   set_offline : in Boolean) is
   105.    begin
   106.       initialize_byte_mode_transfer(the_TP, Q_operand, set_offline);
   107.       words_write_to_EM(the_TP, Q_operand);
   108.       set_lockouts(Q_operand);
   109.    end POD;
   110.
   111.    -- PGAPQq
   112.    overriding
   113.    procedure POE (the_TP      : in out TP.device;
   114.                   Q_operand   : in KDF9.Q_register;
   115.                   set_offline : in Boolean) is
   116.    begin
   117.       require_nonnegative_count(Q_operand.M);
   118.       initialize_byte_mode_gapping(the_TP, Q_operand, set_offline);
   119.    end POE;
   120.
   121.    -- "word gap"
   122.    overriding
   123.    procedure POF (the_TP      : in out TP.device;
   124.                   Q_operand   : in KDF9.Q_register;
   125.                   set_offline : in Boolean) is
   126.    begin
   127.       POE(the_TP, Q_operand, set_offline);
   128.    end POF;
   129.
   130.    TP_quantum : constant := 1E6 / 110;  -- 110 characters per second.
   131.
   132.    TP0 : aliased TP.device (TP0_number,
   133.                             kind    => TP_kind,
   134.                             unit    => 0,
   135.                             quantum => TP_quantum,
   136.                             is_slow => True);
   137.    pragma Unreferenced(TP0);
   138.
   139.    TP1 : aliased TP.device (TP1_number,
   140.                             kind    => TP_kind,
   141.                             unit    => 1,
   142.                             quantum => TP_quantum,
   143.                             is_slow => True);
   144.
   145.    procedure switch_the_shared_buffer_from_TP1 is
   146.    begin
   147.       Finalize(TP1);
   148.    end switch_the_shared_buffer_from_TP1;
   149.
   150. end IOC.two_shift.TP;

Compiling: ../Source\ioc-two_shift-tp.ads
Source file time stamp: 2015-06-18 00:56:20
Compiled at: 2015-10-28 18:14:21

     1. -- ioc-shift_devices-tp.ads
     2. --
     3. -- Emulation of a tape punch buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package IOC.two_shift.TP is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    type device is new IOC.two_shift.device with private;
    24.
    25.    -- PWQq
    26.    overriding
    27.    procedure POA (the_TP      : in out TP.device;
    28.                   Q_operand   : in KDF9.Q_register;
    29.                   set_offline : in Boolean);
    30.    -- PWEQq
    31.    overriding
    32.    procedure POB (the_TP      : in out TP.device;
    33.                   Q_operand   : in KDF9.Q_register;
    34.                   set_offline : in Boolean);
    35.    -- PWCQq
    36.    overriding
    37.    procedure POC (the_TP      : in out TP.device;
    38.                   Q_operand   : in KDF9.Q_register;
    39.                   set_offline : in Boolean);
    40.    -- PWCEQq
    41.    overriding
    42.    procedure POD (the_TP      : in out TP.device;
    43.                   Q_operand   : in KDF9.Q_register;
    44.                   set_offline : in Boolean);
    45.    -- PGAPQq
    46.    overriding
    47.    procedure POE (the_TP      : in out TP.device;
    48.                   Q_operand   : in KDF9.Q_register;
    49.                   set_offline : in Boolean);
    50.    -- ??
    51.    -- This is called "word gap" in the Manual, but never defined.
    52.    -- Assume this acts exactly like POE.
    53.    overriding
    54.    procedure POF (the_TP      : in out TP.device;
    55.                   Q_operand   : in KDF9.Q_register;
    56.                   set_offline : in Boolean);
    57.
    58.    -- TR := (the buffer has been switched from a tape punch to a graph plotter)
    59.    overriding
    60.    procedure PMB (the_TP      : in out TP.device;
    61.                   Q_operand   : in KDF9.Q_register;
    62.                   set_offline : in Boolean);
    63.
    64.    procedure switch_the_shared_buffer_from_TP1;
    65.
    66. private
    67.
    68.    type device is new IOC.two_shift.device with null record;
    69.
    70.    overriding
    71.    procedure Initialize (the_TP : in out TP.device);
    72.
    73.    overriding
    74.    procedure Finalize (the_TP : in out TP.device);
    75.
    76. end IOC.two_shift.TP;

 150 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-cp.adb
Source file time stamp: 2015-06-18 00:56:36
Compiled at: 2015-10-28 18:14:21

     1. -- ioc-cp.adb
     2. --
     3. -- Emulation of a card punch buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with IOC; pragma Elaborate_All(IOC);
    20. with KDF9.store;
    21.
    22.
    23. use  KDF9.store;
    24.
    25. package body IOC.CP is
    26.
    27.    pragma Unsuppress(All_Checks);
    28.
    29.    overriding
    30.    procedure Initialize (the_CP : in out CP.device) is
    31.    begin
    32.       open(the_CP, write_mode, attaching => False);
    33.    end Initialize;
    34.
    35.    overriding
    36.    procedure Finalize (the_CP : in out CP.device) is
    37.    begin
    38.       close(the_CP, "punched", the_CP.unit_count, "card(s)");
    39.    end Finalize;
    40.
    41.    procedure do_output_housekeeping (the_CP     : in out CP.device;
    42.                                     fetched    : in KDF9.word) is
    43.    begin
    44.       flush(the_CP.stream);
    45.       correct_transfer_time(the_CP, actual_length => 1);
    46.       add_in_the_IO_CPU_time(the_CP, fetched);
    47.    end do_output_housekeeping;
    48.
    49.    procedure write_card (the_CP        : in out CP.device;
    50.                          Q_operand     : in KDF9.Q_register;
    51.                          max_words     : in KDF9.address;
    52.                          writing_to_EM : in Boolean := False) is
    53.       start_address : constant KDF9.address := Q_operand.I;
    54.       end_address   : constant KDF9.address := Q_operand.M;
    55.       size : KDF9.word := 0;
    56.       char : Character;
    57.       byte : KDF9.symbol;
    58.    begin
    59.       validate_range_access(start_address, end_address);
    60.    word_loop:
    61.       for w in start_address .. KDF9.address'Min(end_address, start_address+max_words-1) loop
    62.          for c in KDF9.symbol_number'Range loop
    63.             byte := fetch_symbol(w, c);
    64.             size := size + 1;
    65.             char := to_CP(byte);
    66.             put_byte(char, the_CP.stream);
    67.             exit word_loop when writing_to_EM and char = KDF9.E_M;
    68.          end loop;
    69.       end loop word_loop;
    70.       put_EOL(the_CP.stream);
    71.       the_CP.unit_count := the_CP.unit_count + 1;
    72.       do_output_housekeeping(the_CP, fetched => size);
    73.    end write_card;
    74.
    75.    procedure words_write_card (the_CP        : in out CP.device;
    76.                                Q_operand     : in KDF9.Q_register;
    77.                                max_words     : in KDF9.address;
    78.                                writing_to_EM : in Boolean := False) is
    79.
    80.       start_address : constant KDF9.address := Q_operand.I;
    81.       end_address   : constant KDF9.address := Q_operand.M;
    82.       size : KDF9.word := 0;
    83.       char : Character;
    84.       byte : KDF9.symbol;
    85.    begin
    86.       validate_range_access(start_address, end_address);
    87.       for w in start_address .. KDF9.address'Min(end_address, start_address+max_words-1) loop
    88.          byte := KDF9.symbol(fetch_word(w) and 8#77#);
    89.          size := size + 1;
    90.             char := to_CP(byte);
    91.          put_byte(char, the_CP.stream);
    92.       exit when writing_to_EM and char = KDF9.E_M;
    93.       end loop;
    94.       put_EOL(the_CP.stream);
    95.       the_CP.unit_count := the_CP.unit_count + 1;
    96.       do_output_housekeeping(the_CP, fetched => size);
    97.    end words_write_card;
    98.
    99.    overriding
   100.    procedure POA (the_CP      : in out CP.device;
   101.                   Q_operand   : in KDF9.Q_register;
   102.                   set_offline : in Boolean) is
   103.    begin
   104.       initialize_byte_mode_transfer(the_CP, Q_operand, set_offline);
   105.       write_card(the_CP, Q_operand, max_words => 160);
   106.       set_lockouts(Q_operand);
   107.    end POA;
   108.
   109.    overriding
   110.    procedure POB (the_CP      : in out CP.device;
   111.                   Q_operand   : in KDF9.Q_register;
   112.                   set_offline : in Boolean) is
   113.    begin
   114.       initialize_byte_mode_transfer(the_CP, Q_operand, set_offline);
   115.       write_card(the_CP, Q_operand, max_words => 160, writing_to_EM => True);
   116.       set_lockouts(Q_operand);
   117.    end POB;
   118.
   119.    overriding
   120.    procedure POC (the_CP      : in out CP.device;
   121.                   Q_operand   : in KDF9.Q_register;
   122.                   set_offline : in Boolean) is
   123.    begin
   124.       initialize_byte_mode_transfer(the_CP, Q_operand, set_offline);
   125.       words_write_card(the_CP, Q_operand, max_words => 160);
   126.       set_lockouts(Q_operand);
   127.    end POC;
   128.
   129.    overriding
   130.    procedure POD (the_CP      : in out CP.device;
   131.                   Q_operand   : in KDF9.Q_register;
   132.                   set_offline : in Boolean) is
   133.    begin
   134.       initialize_byte_mode_transfer(the_CP, Q_operand, set_offline);
   135.       words_write_card(the_CP, Q_operand, max_words => 160, writing_to_EM => True);
   136.       set_lockouts(Q_operand);
   137.    end POD;
   138.
   139.    overriding
   140.    procedure POE (the_CP      : in out CP.device;
   141.                   Q_operand   : in KDF9.Q_register;
   142.                   set_offline : in Boolean) is
   143.    begin
   144.       POC(the_CP, Q_operand, set_offline);
   145.    end POE;
   146.
   147.    overriding
   148.    procedure POF (the_CP      : in out CP.device;
   149.                   Q_operand   : in KDF9.Q_register;
   150.                   set_offline : in Boolean) is
   151.    begin
   152.       POA(the_CP, Q_operand, set_offline);
   153.    end POF;
   154.
   155.    overriding
   156.    procedure POG (the_CP      : in out CP.device;
   157.                   Q_operand   : in KDF9.Q_register;
   158.                   set_offline : in Boolean) is
   159.    begin
   160.       initialize_byte_mode_transfer(the_CP, Q_operand, set_offline);
   161.       write_card(the_CP, Q_operand, max_words => 80, writing_to_EM => False);
   162.       set_lockouts(Q_operand);
   163.    end POG;
   164.
   165.    overriding
   166.    procedure POH (the_CP      : in out CP.device;
   167.                   Q_operand   : in KDF9.Q_register;
   168.                   set_offline : in Boolean) is
   169.    begin
   170.       initialize_byte_mode_transfer(the_CP, Q_operand, set_offline);
   171.       write_card(the_CP, Q_operand, max_words => 80, writing_to_EM => True);
   172.       set_lockouts(Q_operand);
   173.    end POH;
   174.
   175.    overriding
   176.    procedure POK (the_CP      : in out CP.device;
   177.                   Q_operand   : in KDF9.Q_register;
   178.                   set_offline : in Boolean) is
   179.    begin
   180.       initialize_byte_mode_transfer(the_CP, Q_operand, set_offline);
   181.       -- See the Manual, p289.
   182.       words_write_card(the_CP, Q_operand, max_words => 80, writing_to_EM => True);
   183.       set_lockouts(Q_operand);
   184.    end POK;
   185.
   186.    overriding
   187.    procedure POL (the_CP      : in out CP.device;
   188.                   Q_operand   : in KDF9.Q_register;
   189.                   set_offline : in Boolean) is
   190.    begin
   191.       initialize_byte_mode_transfer(the_CP, Q_operand, set_offline);
   192.       -- See the Manual, p289.
   193.       words_write_card(the_CP, Q_operand, max_words => 80, writing_to_EM => False);
   194.       set_lockouts(Q_operand);
   195.    end POL;
   196.
   197.    CP_quantum : constant := 1E6 / (300 / 60); -- 300 cards per minute.
   198.
   199.    CP0 : aliased CP.device (number  => CP0_number,
   200.                             kind    => CP_kind,
   201.                             unit    => 0,
   202.                             quantum => CP_quantum,
   203.                             is_slow => True);
   204.    pragma Unreferenced(CP0);
   205.
   206. end IOC.CP;

Compiling: ../Source\ioc-cp.ads
Source file time stamp: 2015-06-18 00:56:36
Compiled at: 2015-10-28 18:14:21

     1. -- ioc-cp.ads
     2. --
     3. -- Emulation of a card punch buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package IOC.CP is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    type device is new IOC.unit_record_device with private;
    24.
    25.    -- Punch binary mode.
    26.    overriding
    27.    procedure POA (the_CP      : in out CP.device;
    28.                   Q_operand   : in KDF9.Q_register;
    29.                   set_offline : in Boolean);
    30.    -- Punch binary mode to End Message.
    31.    overriding
    32.    procedure POB (the_CP      : in out CP.device;
    33.                   Q_operand   : in KDF9.Q_register;
    34.                   set_offline : in Boolean);
    35.    -- Punch binary character mode.
    36.    overriding
    37.    procedure POC (the_CP      : in out CP.device;
    38.                   Q_operand   : in KDF9.Q_register;
    39.                   set_offline : in Boolean);
    40.    -- Punch binary character mode to End Message.
    41.    overriding
    42.    procedure POD (the_CP      : in out CP.device;
    43.                   Q_operand   : in KDF9.Q_register;
    44.                   set_offline : in Boolean);
    45.    -- As POC.
    46.    overriding
    47.    procedure POE (the_CP      : in out CP.device;
    48.                   Q_operand   : in KDF9.Q_register;
    49.                   set_offline : in Boolean);
    50.    -- As POA.
    51.    overriding
    52.    procedure POF (the_CP      : in out CP.device;
    53.                   Q_operand   : in KDF9.Q_register;
    54.                   set_offline : in Boolean);
    55.    -- Punch alphanumeric mode.
    56.    overriding
    57.    procedure POG (the_CP      : in out CP.device;
    58.                   Q_operand   : in KDF9.Q_register;
    59.                   set_offline : in Boolean);
    60.    -- Punch alphanumeric mode to End Message.
    61.    overriding
    62.    procedure POH (the_CP      : in out CP.device;
    63.                   Q_operand   : in KDF9.Q_register;
    64.                   set_offline : in Boolean);
    65.    -- Punch alphanumeric character mode to End Message.
    66.    overriding
    67.    procedure POK (the_CP      : in out CP.device;
    68.                   Q_operand   : in KDF9.Q_register;
    69.                   set_offline : in Boolean);
    70.    -- Punch alphanumeric character mode.
    71.    overriding
    72.    procedure POL (the_CP      : in out CP.device;
    73.                   Q_operand   : in KDF9.Q_register;
    74.                   set_offline : in Boolean);
    75.
    76. private
    77.
    78.    type device is new IOC.unit_record_device with null record;
    79.
    80.    overriding
    81.    procedure Initialize (the_CP : in out CP.device);
    82.
    83.    overriding
    84.    procedure Finalize (the_CP : in out CP.device);
    85.
    86. end IOC.CP;

 206 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-cr.adb
Source file time stamp: 2015-06-18 00:56:34
Compiled at: 2015-10-28 18:14:22

     1. -- ioc-cr.adb
     2. --
     3. -- Emulation of a card reader buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with IOC; pragma Elaborate_All(IOC);
    20. with KDF9.store;
    21.
    22.
    23. use  KDF9.store;
    24.
    25. package body IOC.CR is
    26.
    27.    pragma Unsuppress(All_Checks);
    28.
    29.    use Latin_1;
    30.
    31.    overriding
    32.    procedure Initialize (the_CR : in out CR.device) is
    33.    begin
    34.       open(the_CR, read_mode, attaching => False);
    35.    end Initialize;
    36.
    37.    overriding
    38.    procedure Finalize (the_CR : in out CR.device) is
    39.    begin
    40.       close(the_CR, "read", the_CR.unit_count, "card(s)");
    41.    end Finalize;
    42.
    43.    blank_card : constant String(max_card_columns) := (others => Space);
    44.
    45.    procedure get_card_image (the_CR         : in out CR.device;
    46.                               size          : in out KDF9.word;
    47.                               max_columns   : in KDF9.address;
    48.                               reading_to_EM : in Boolean := False) is
    49.       max  : constant Positive := Positive(max_columns);
    50.       char : Character;
    51.    begin
    52.       -- Clear out the card image field.
    53.       the_CR.card_image(1..max) := blank_card(1..max);
    54.       -- Fill as much of the card image as possible with the next data line, padded out with
    55.       --    blanks, so that it is unnecessary to type all 80 or 160 characters.
    56.       -- For transfers to End Message, a line terminator must follow the E_M.
    57.       for i in 1 .. max loop
    58.          get_char_from_stream (char, the_CR, size);
    59.       exit when char = LF;
    60.          the_CR.card_image(i) := char;
    61.       exit when reading_to_EM and char = KDF9.E_M;
    62.       end loop;
    63.       -- Discard excess characters in the current data line.
    64.       while char /= LF loop
    65.          get_char(char, the_CR.stream);  -- N.B. do not update size for discards.
    66.       end loop;
    67.       the_CR.unit_count := the_CR.unit_count + 1;
    68.    exception
    69.       when end_of_stream =>
    70.          the_CR.is_abnormal := True;
    71.    end get_card_image;
    72.
    73.    procedure do_input_housekeeping (the_CR : in out CR.device;
    74.                                     fetched    : in KDF9.word) is
    75.    begin
    76.       add_in_the_IO_CPU_time(the_CR, fetched);
    77.       correct_transfer_time(the_CR, actual_length => 1);
    78.    end do_input_housekeeping;
    79.
    80.    procedure read_card (the_CR        : in out CR.device;
    81.                         Q_operand     : in KDF9.Q_register;
    82.                         max_words     : in KDF9.address;
    83.                         reading_to_EM : in Boolean := False) is
    84.       start_address : constant KDF9.address := Q_operand.I;
    85.       end_address   : constant KDF9.address := Q_operand.M;
    86.       size : KDF9.word := 0;
    87.       next : Natural := 0;
    88.       char : Character;
    89.       byte : KDF9.symbol;
    90.    begin
    91.       validate_range_access(start_address, end_address);
    92.       get_card_image(the_CR, size, max_columns => max_words*8);
    93.       if the_CR.is_abnormal then return; end if;
    94.    word_loop:
    95.       for w in start_address .. KDF9.address'Min(end_address, start_address+max_words-1) loop
    96.          for c in KDF9.symbol_number'Range loop
    97.             next := next + 1;
    98.             char := the_CR.card_image(next);
    99.             byte := CR_in(char);
   100.             -- CR goes abnormal if the data character is not in the supported character set.
   101.             the_CR.is_abnormal := the_CR.is_abnormal or
   102.                                       (byte = KDF9.Word_Filler and char /= KDF9.W_F);
   103.             store_symbol(byte, w, c);
   104.             if reading_to_EM and byte = KDF9.End_Message then
   105.                for d in 1 .. 7-c loop
   106.                   store_symbol(KDF9.Blank_Space, w, c+d);
   107.                end loop;
   108.                exit word_loop;
   109.             end if;
   110.          end loop;
   111.       end loop word_loop;
   112.       do_input_housekeeping(the_CR, size);
   113.    exception
   114.       when end_of_stream =>
   115.          flush(the_CR.stream);
   116.          do_input_housekeeping(the_CR, size);
   117.    end read_card;
   118.
   119.    procedure words_read_card (the_CR        : in out CR.device;
   120.                               Q_operand     : in KDF9.Q_register;
   121.                               max_words     : in KDF9.address;
   122.                               reading_to_EM : in Boolean := False) is
   123.       start_address : constant KDF9.address := Q_operand.I;
   124.       end_address   : constant KDF9.address := Q_operand.M;
   125.       size : KDF9.word := 0;
   126.       next : Natural := 0;
   127.       char : Character;
   128.       word : KDF9.word;
   129.    begin
   130.       validate_range_access(start_address, end_address);
   131.       get_card_image(the_CR, size, max_columns => max_words);
   132.       if the_CR.is_abnormal then return; end if;
   133.       for w in start_address .. KDF9.address'Min(end_address, start_address+max_words-1) loop
   134.          next := next + 1;
   135.          char := the_CR.card_image(next);
   136.          word := KDF9.word(CR_in(char));
   137.          -- CR goes abnormal if the data character is not in the supported character set.
   138.          the_CR.is_abnormal := the_CR.is_abnormal or
   139.                                    (word = KDF9.word(KDF9.Word_Filler) and char /= KDF9.W_F);
   140.          store_word(word, w);
   141.       exit when reading_to_EM and char = KDF9.E_M;
   142.       end loop;
   143.       add_in_the_IO_CPU_time(the_CR, size);
   144.       correct_transfer_time(the_CR, actual_length => 1);
   145.    exception
   146.       when end_of_stream =>
   147.          flush(the_CR.stream);
   148.          add_in_the_IO_CPU_time(the_CR, size);
   149.          correct_transfer_time(the_CR, actual_length => 1);
   150.    end words_read_card;
   151.
   152.    overriding
   153.    procedure PIA (the_CR      : in out CR.device;
   154.                   Q_operand   : in KDF9.Q_register;
   155.                   set_offline : in Boolean) is
   156.    begin
   157.       initialize_byte_mode_transfer(the_CR, Q_operand, set_offline);
   158.       read_card(the_CR, Q_operand, max_words => 20);
   159.       set_lockouts(Q_operand);
   160.    end PIA;
   161.
   162.    overriding
   163.    procedure PIB (the_CR      : in out CR.device;
   164.                   Q_operand   : in KDF9.Q_register;
   165.                   set_offline : in Boolean) is
   166.    begin
   167.       initialize_byte_mode_transfer(the_CR, Q_operand, set_offline);
   168.       read_card(the_CR, Q_operand, max_words => 20, reading_to_EM => True);
   169.       set_lockouts(Q_operand);
   170.    end PIB;
   171.
   172.    overriding
   173.    procedure PIC (the_CR      : in out CR.device;
   174.                   Q_operand   : in KDF9.Q_register;
   175.                   set_offline : in Boolean) is
   176.    begin
   177.       initialize_byte_mode_transfer(the_CR, Q_operand, set_offline);
   178.       words_read_card(the_CR, Q_operand, max_words => 160);
   179.       set_lockouts(Q_operand);
   180.    end PIC;
   181.
   182.    overriding
   183.    procedure PID (the_CR      : in out CR.device;
   184.                   Q_operand   : in KDF9.Q_register;
   185.                   set_offline : in Boolean) is
   186.    begin
   187.       initialize_byte_mode_transfer(the_CR, Q_operand, set_offline);
   188.       words_read_card(the_CR, Q_operand, max_words => 160, reading_to_EM => True);
   189.       set_lockouts(Q_operand);
   190.    end PID;
   191.
   192.    overriding
   193.    procedure PIE (the_CR      : in out CR.device;
   194.                   Q_operand   : in KDF9.Q_register;
   195.                   set_offline : in Boolean) is
   196.    begin
   197.       initialize_byte_mode_transfer(the_CR, Q_operand, set_offline);
   198.       read_card(the_CR, Q_operand, max_words => 10);
   199.       set_lockouts(Q_operand);
   200.    end PIE;
   201.
   202.    overriding
   203.    procedure PIF (the_CR      : in out CR.device;
   204.                   Q_operand   : in KDF9.Q_register;
   205.                   set_offline : in Boolean) is
   206.    begin
   207.       initialize_byte_mode_transfer(the_CR, Q_operand, set_offline);
   208.       read_card(the_CR, Q_operand, max_words => 10, reading_to_EM => True);
   209.       set_lockouts(Q_operand);
   210.    end PIF;
   211.
   212.    overriding
   213.    procedure PIG (the_CR      : in out CR.device;
   214.                   Q_operand   : in KDF9.Q_register;
   215.                   set_offline : in Boolean) is
   216.    begin
   217.       initialize_byte_mode_transfer(the_CR, Q_operand, set_offline);
   218.       words_read_card(the_CR, Q_operand, max_words => 80);
   219.       set_lockouts(Q_operand);
   220.    end PIG;
   221.
   222.    overriding
   223.    procedure PIH (the_CR      : in out CR.device;
   224.                   Q_operand   : in KDF9.Q_register;
   225.                   set_offline : in Boolean) is
   226.    begin
   227.       initialize_byte_mode_transfer(the_CR, Q_operand, set_offline);
   228.       words_read_card(the_CR, Q_operand, max_words => 80, reading_to_EM => True);
   229.       set_lockouts(Q_operand);
   230.    end PIH;
   231.
   232.    -- the_T_bit := (RECHECK switch is OFF). {It always is nowadays!}
   233.    overriding
   234.    procedure PMB (the_CR      : in out CR.device;
   235.                   Q_operand   : in KDF9.Q_register;
   236.                   set_offline : in Boolean) is
   237.       pragma Unreferenced(set_offline);
   238.    begin
   239.       validate_device(the_CR, Q_operand);
   240.       validate_parity(the_CR);
   241.       the_T_bit := 1;
   242.       take_note_of(Q_operand, the_CR.device_name, the_T_bit);
   243.    end PMB;
   244.
   245.    CR_quantum : constant := 1E6 / (600 / 60); -- 600 cards per minute.
   246.
   247.    CR0 : aliased CR.device (number  => CR0_number,
   248.                             kind    => CR_kind,
   249.                             unit    => 0,
   250.                             quantum => CR_quantum,
   251.                             is_slow => True);
   252.    pragma Unreferenced(CR0);
   253.
   254. end IOC.CR;

Compiling: ../Source\ioc-cr.ads
Source file time stamp: 2015-06-18 00:56:34
Compiled at: 2015-10-28 18:14:22

     1. -- ioc-cr.ads
     2. --
     3. -- Emulation of a card reader buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package IOC.CR is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    type device is new IOC.unit_record_device with private;
    24.
    25.    -- Binary (undecoded) read
    26.    overriding
    27.    procedure PIA (the_CR      : in out CR.device;
    28.                   Q_operand   : in KDF9.Q_register;
    29.                   set_offline : in Boolean);
    30.    -- Binary (undecoded) read to End_Message
    31.    overriding
    32.    procedure PIB (the_CR      : in out CR.device;
    33.                   Q_operand   : in KDF9.Q_register;
    34.                   set_offline : in Boolean);
    35.    -- Binary (undecoded) character read
    36.    overriding
    37.    procedure PIC (the_CR      : in out CR.device;
    38.                   Q_operand   : in KDF9.Q_register;
    39.                   set_offline : in Boolean);
    40.    -- Binary (undecoded) character read to End_Message
    41.    overriding
    42.    procedure PID (the_CR      : in out CR.device;
    43.                   Q_operand   : in KDF9.Q_register;
    44.                   set_offline : in Boolean);
    45.    -- Alphanumeric (decoded) read
    46.    overriding
    47.    procedure PIE (the_CR      : in out CR.device;
    48.                   Q_operand   : in KDF9.Q_register;
    49.                   set_offline : in Boolean);
    50.    -- Alphanumeric (decoded) read to End_Message
    51.    overriding
    52.    procedure PIF (the_CR      : in out CR.device;
    53.                   Q_operand   : in KDF9.Q_register;
    54.                   set_offline : in Boolean);
    55.    -- Alphanumeric (decoded) character read
    56.    overriding
    57.    procedure PIG (the_CR      : in out CR.device;
    58.                   Q_operand   : in KDF9.Q_register;
    59.                   set_offline : in Boolean);
    60.    -- Alphanumeric (decoded) character read to End_Message
    61.    overriding
    62.    procedure PIH (the_CR      : in out CR.device;
    63.                   Q_operand   : in KDF9.Q_register;
    64.                   set_offline : in Boolean);
    65.
    66.    -- the_T_bit := (RECHECK switch is OFF)
    67.    overriding
    68.    procedure PMB (the_CR      : in out CR.device;
    69.                   Q_operand   : in KDF9.Q_register;
    70.                   set_offline : in Boolean);
    71.
    72. private
    73.
    74.    subtype max_card_columns is Positive range 1 .. 160;
    75.
    76.    type device is new IOC.unit_record_device with
    77.       record
    78.          card_image : String(max_card_columns);
    79.       end record;
    80.
    81.    overriding
    82.    procedure Initialize (the_CR : in out CR.device);
    83.
    84.    overriding
    85.    procedure Finalize (the_CR : in out CR.device);
    86.
    87. end IOC.CR;

 254 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-fd.adb
Source file time stamp: 2015-06-18 00:56:32
Compiled at: 2015-10-28 18:14:23

     1. -- ioc-fd.adb
     2. --
     3. -- Emulation of a fixed disc drive buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with IOC; pragma Elaborate_All(IOC);
    20. with exceptions;
    21. with formatting;
    22. with KDF9.store;
    23. with POSIX;
    24. with settings;
    25.
    26. use  exceptions;
    27. use  formatting;
    28. use  KDF9.store;
    29. use  POSIX;
    30. use  settings;
    31.
    32. package body IOC.FD is
    33.
    34.    pragma Unsuppress(All_Checks);
    35.
    36.    -- Hypothesis:
    37.    -- Where a specification of the Fixed Disc subsystem cannot be inferred from extant
    38.    -- software, such as the Eldon 2 Director, or the EE KDF9 Programming Manual,
    39.    -- then it is reasonable to extrapolate from the document:
    40.    --    "GENERAL INFORMATION MANUAL dp/f-5022 DISCfILE (sic) STORAGE SYSTEM",
    41.    -- by Data Products Corporation, dated March 1965; which describes a similar model.
    42.    -- This document is referred to here as "GIM".
    43.    -- Confirmation of much of this material has been gained from the ICT document:
    44.    --    "Data Disc Store 1956:, dated September 1964"
    45.    -- which describes the same device offered as the first disc drive for the 1900 Series.
    46.    -- All three depict the drive as having a different division of tracks into sectors.
    47.
    48.    overriding
    49.    procedure Initialize (the_FD : in out FD.device) is
    50.    begin
    51.       open(the_FD, rd_wr_mode, attaching => False);
    52.    end Initialize;
    53.
    54.    overriding
    55.    procedure Finalize (the_FD : in out FD.device) is
    56.    begin
    57.       if the_FD.is_open then
    58.          if the_final_state_is_wanted and
    59.                (the_FD.usage      /= 0 or the_FD.latency_count /= 0 or
    60.                 the_FD.seek_count /= 0 or the_FD.switch_time   /= 0) then
    61.             output_line
    62.                    (the_FD.device_name
    63.                   & " on buffer #"
    64.                   & oct_of(KDF9.Q_part(the_FD.number), 2)
    65.                   & " spent:"
    66.                    );
    67.             output_line
    68.                    ("   "
    69.                   & KDF9.microseconds'Image(the_FD.switch_time / 1_000)
    70.                   & " ms in drive-switching,"
    71.                    );
    72.             output_line
    73.                    ("   "
    74.                   & KDF9.microseconds'Image(the_FD.seek_time / 1_000)
    75.                   & " ms in"
    76.                   & KDF9.word'Image(the_FD.seek_count)
    77.                   & " seek(s),"
    78.                    );
    79.             output_line
    80.                    ("   "
    81.                   & KDF9.microseconds'Image(the_FD.latency_time / 1_000)
    82.                   & " ms in"
    83.                   & KDF9.word'Image(the_FD.latency_count)
    84.                   & " rotational latencies, and"
    85.                    );
    86.             output_line
    87.                    ("   "
    88.                   & KDF9.microseconds'Image(the_FD.data_time / 1_000)
    89.                   & " ms in transferring"
    90.                   & KDF9.word'Image(the_FD.usage)
    91.                   & " character(s)."
    92.                    );
    93.          end if;
    94.          IOC.device(the_FD).Finalize;
    95.          close(the_FD);
    96.       end if;
    97.    exception
    98.       when others =>
    99.          output_line("Finalize error for buffer #" & oct_of(KDF9.Q_part(the_FD.number)));
   100.          raise;
   101.    end Finalize;
   102.
   103.    overriding
   104.    function usage (the_FD : FD.device)
   105.    return KDF9.word is
   106.    begin
   107.       return the_FD.byte_count;
   108.    end usage;
   109.
   110.    overriding
   111.    function IO_elapsed_time_total (the_FD : FD.device)
   112.    return KDF9.microseconds is
   113.    begin
   114.       return the_FD.elapsed_time_total;
   115.    end IO_elapsed_time_total;
   116.
   117.    -- For brevity:
   118.    subtype us is KDF9.microseconds;
   119.
   120.    -- Hypothesis:
   121.    -- The locus is set by a seek operation; the sector_number is updated by a transfer;
   122.    --     but the arm motion does not take place until the read/write operation,
   123.    --        according to David Holdsworth.
   124.    -- Hypothesis:
   125.    -- A seek command sets sector_number to 0.
   126.    -- Hypothesis:
   127.    -- A data transfer command updates sector_number to the next sequential sector number.
   128.    -- Hypothesis:
   129.    -- If a transfer would increase sector_number past 95, the end-of-area flag is set,
   130.    --     and sector_number is set to 95.
   131.
   132.    function sector_span (Q_operand : KDF9.Q_register)
   133.    return KDF9.Q_part is
   134.    begin
   135.       return (Q_operand.M - Q_operand.I + sector_size - 1) / sector_size;
   136.    end sector_span;
   137.
   138.    function updated_locus (the_FD    : FD.device;
   139.                            Q_operand : KDF9.Q_register)
   140.    return FD_layout.locus is
   141.       the_new_locus : FD_layout.locus := the_FD.locus;
   142.    begin
   143.       if the_FD.locus.sector_number + sector_span(Q_operand) > FD_layout.sector_number'Last then
   144.          the_new_locus.sector_number := FD_layout.sector_number'Last;
   145.          the_new_locus.is_at_end_of_area := 1;
   146.       else
   147.          the_new_locus.sector_number := the_FD.locus.sector_number + sector_span(Q_operand);
   148.          the_new_locus.is_at_end_of_area := 0;
   149.       end if;
   150.       return the_new_locus;
   151.    end updated_locus;
   152.
   153.    procedure advance_the_sector_number (the_FD   : in out FD.device) is
   154.    begin
   155.       if the_FD.locus.sector_number = FD_layout.sector_number'Last then
   156.          the_FD.locus.is_at_end_of_area := 1;
   157.       else
   158.          the_FD.locus.is_at_end_of_area := 0;
   159.          the_FD.locus.sector_number := the_FD.locus.sector_number + 1;
   160.       end if;
   161.    end advance_the_sector_number;
   162.
   163.    procedure set_the_sector_number (the_FD    : in out FD.device;
   164.                                     Q_operand : in KDF9.Q_register) is
   165.       the_sector_number : constant KDF9.Q_part := Q_operand.C / 16; -- remove the buffer number
   166.    begin
   167.       if the_sector_number >= FD_layout.sector_number'Last then
   168.          the_FD.locus.is_at_end_of_area := 1;
   169.          the_FD.locus.sector_number := FD_layout.sector_number'Last;
   170.       else
   171.          the_FD.locus.is_at_end_of_area := 0;
   172.          the_FD.locus.sector_number := the_sector_number;
   173.       end if;
   174.    end set_the_sector_number;
   175.
   176.    sectors_per_platter : constant := sectors_per_seek_area * seek_areas_per_platter;
   177.    sectors_per_drive   : constant := platters_per_drive  * sectors_per_platter;
   178.
   179.    function file_offset (locus : FD_layout.locus)
   180.    return POSIX.file_position is
   181.    begin
   182.       return (bytes_per_sector *
   183.                ( POSIX.file_position(locus.drive_number)     * sectors_per_drive
   184.                + POSIX.file_position(locus.platter_number)   * sectors_per_platter
   185.                + POSIX.file_position(locus.seek_area_number) * sectors_per_seek_area
   186.                + POSIX.file_position(locus.sector_number)    * 1
   187.                )
   188.              );
   189.    end file_offset;
   190.
   191.    function transfer_time (first : FD_layout.sector_number; size : KDF9.word)
   192.    return us is
   193.
   194.       function ceiling (point : KDF9.Q_part; size : KDF9.word)
   195.       return FD_layout.sector_number is
   196.          length : constant KDF9.Q_part := sector_span((0, 1, KDF9.Q_part(size)));
   197.       begin
   198.          return FD_layout.sector_number'Min(point + length - 1, FD_layout.sector_number'Last);
   199.       end ceiling;
   200.
   201.       -- These rates come from the Manual, §6.1.
   202.       outer_rate : constant := 84_800;          -- bytes per second in the outer zone
   203.       inner_rate : constant := outer_rate / 2;  -- bytes per second in the outer zone
   204.       boundary   : constant := sectors_per_seek_area / 3 * 2;
   205.       last       : constant FD_layout.sector_number := ceiling(first, size);
   206.
   207.       function time_for (bytes : KDF9.word; in_outer_zone : Boolean)
   208.       return KDF9.word is
   209.       begin
   210.          if in_outer_zone then
   211.             return 1E6 * bytes / outer_rate;
   212.          else
   213.             return 1E6 * bytes / inner_rate;
   214.          end if;
   215.       end time_for;
   216.
   217.       bytes_left : KDF9.word := size;
   218.       total_time : KDF9.word := 0;
   219.
   220.    begin
   221.       for s in first .. last loop
   222.       exit when bytes_left < bytes_per_sector;
   223.          total_time := total_time + time_for(bytes_per_sector, in_outer_zone => s < boundary);
   224.          bytes_left := bytes_left - bytes_per_sector;
   225.       end loop;
   226.       if bytes_left /= 0 then
   227.          total_time := total_time + time_for(bytes_left, in_outer_zone => last < boundary);
   228.       end if;
   229.       return us(total_time);
   230.    end transfer_time;
   231.
   232.    -- The rotational position of the disc is measured in term of the time,
   233.    --    in microseconds, taken to get to that position from sector 0.
   234.
   235.    rotation_time : constant := 60E3;  -- 1000 RPM => 60 ms = 60_000 us
   236.    track_size    : constant := 16;    -- There are only 8 sectors per track in the inner zone.
   237.    sector_time   : constant := rotation_time / track_size;
   238.
   239.    function angular_position (sector_number : FD_layout.sector_number)
   240.    return us is
   241.    begin
   242.       if sector_number >= track_size * 4 then
   243.          -- We are in the inner zone, with half as many sectors.
   244.          return us((sector_number * 2) mod track_size * sector_time);
   245.       else
   246.          -- We are in the outer zone.
   247.          return us((sector_number * 1) mod track_size * sector_time);
   248.       end if;
   249.    end angular_position;
   250.
   251.    function latent_time (sector_number : FD_layout.sector_number)
   252.    return us is
   253.       new_angle  : constant us := angular_position(sector_number);
   254.       old_angle  : constant us := the_clock_time mod rotation_time;
   255.    begin
   256.       -- According to GIM, the minimum latency_time is one sector time.
   257.       return us'Max((new_angle - old_angle) mod rotation_time, sector_time);
   258.    end latent_time;
   259.
   260.    -- These times come from the Manual, §6.1.
   261.    checking_time  : constant :=   39E3;
   262.    min_seek_time  : constant :=  156E3 - checking_time;
   263.    max_seek_time  : constant :=  368E3 - checking_time;
   264.    per_track_time : constant us := us(max_seek_time - min_seek_time) / seek_areas_per_platter;
   265.
   266.    function arm_seek_time (the_FD : FD.device)
   267.    return us is
   268.       stroke : us := 0;
   269.    begin
   270.       if the_FD.target.platter_number /= the_FD.locus.platter_number then
   271.          declare
   272.             this : constant FD_layout.seek_area_number := the_FD.comb(the_FD.target.platter_number);
   273.             next : constant FD_layout.seek_area_number := the_FD.target.seek_area_number;
   274.          begin
   275.             if this >= next then
   276.                stroke := us(this - next);
   277.             else
   278.                stroke := us(next - this);
   279.             end if;
   280.          end;
   281.       end if;
   282.       if stroke > 0 then
   283.          -- Hypothesis:
   284.          -- A seek distance of 1 position takes the minimum seek time.
   285.          return us'Min(min_seek_time + stroke*per_track_time - per_track_time, max_seek_time)
   286.               + checking_time;
   287.       else
   288.          -- Hypothesis:
   289.          -- A seek to the present position takes no time.
   290.          return 0;
   291.       end if;
   292.    end arm_seek_time;
   293.
   294.    function platter_switch_time (the_FD : FD.device)
   295.    return us is
   296.    begin
   297.       if the_FD.target.platter_number = the_FD.locus.platter_number then
   298.          -- Hypothesis:
   299.          -- Opersting on the current platter incurs no switch time.
   300.          return 0;
   301.       else
   302.          -- Hypothesis:
   303.          -- A switch to a different platter_number takes 26 ms on average, as specified in GIM.
   304.          return 26_000;
   305.       end if;
   306.    end platter_switch_time;
   307.
   308.    procedure update_statistics (the_FD        : in out FD.device;
   309.                                 switch_time,
   310.                                 seek_time,
   311.                                 latency_time,
   312.                                 data_time     : in us := 0) is
   313.       real_time : us;
   314.    begin
   315.       the_FD.switch_time := the_FD.switch_time + switch_time;
   316.       the_FD.seek_time := the_FD.seek_time + seek_time;
   317.       the_FD.latency_time := the_FD.latency_time + latency_time;
   318.       the_FD.data_time := the_FD.data_time + data_time;
   319.       real_time := seek_time + latency_time + data_time;
   320.       the_FD.elapsed_time_total := the_FD.elapsed_time_total + real_time;
   321.       add_in_the_IO_CPU_time(data_time);
   322.    end update_statistics;
   323.
   324.    procedure select_new_seek_area (the_FD       : in out FD.device;
   325.                                    switch_time,
   326.                                    seek_time    : out us) is
   327.    begin
   328.       switch_time := platter_switch_time(the_FD);
   329.       seek_time := arm_seek_time(the_FD);
   330.       the_FD.locus := the_FD.target;
   331.       if the_FD.comb(the_FD.locus.platter_number) /= the_FD.locus.seek_area_number then
   332.          the_FD.comb(the_FD.locus.platter_number) := the_FD.locus.seek_area_number;
   333.          the_FD.seek_count := the_FD.seek_count + 1;
   334.       end if;
   335.     end select_new_seek_area;
   336.
   337.    subtype sector_image is String(1 .. bytes_per_sector);
   338.
   339.    empty_sector : constant sector_image := (others => ' ');
   340.    this_sector  : sector_image;
   341.
   342.    procedure get_next_sector (the_FD : in out FD.device) is
   343.       byte_address : constant POSIX.file_position := file_offset(the_FD.locus);
   344.       byte_count   : Integer;
   345.    begin
   346.       if seek(fd_of(the_FD.stream), byte_address) /= byte_address then
   347.          raise emulation_failure with "seek failure in get_next_sector";
   348.       end if;
   349.       byte_count := read(fd_of(the_FD.stream), this_sector, bytes_per_sector);
   350.       if byte_count /= bytes_per_sector and then  -- A short transfer ..
   351.             byte_count /= 0                 then  -- ... is OK at EOF with a 0 count.
   352.          raise emulation_failure with "read failure in get_next_sector";
   353.       end if;
   354.       the_FD.sector_count := the_FD.sector_count + 1;
   355.       advance_the_sector_number(the_FD);
   356.    end get_next_sector;
   357.
   358.    procedure keep_house (the_FD        : in out FD.device;
   359.                          transfer_size : in KDF9.word;
   360.                          the_data_time : out us) is
   361.    begin
   362.       the_FD.latency_count := the_FD.latency_count + 1;
   363.       the_FD.byte_count := the_FD.byte_count + transfer_size;
   364.       add_in_the_IO_CPU_time(the_FD, transfer_size);
   365.       the_data_time := transfer_time(the_FD.locus.sector_number, transfer_size);
   366.    end keep_house;
   367.
   368.    procedure read (the_FD        : in out FD.device;
   369.                    start_address,
   370.                    end_address   : in  KDF9.address;
   371.                    the_data_time : out us;
   372.                    reading_to_EM : in  Boolean := False) is
   373.       size : KDF9.word := 0;
   374.       next : Natural := 0;
   375.       char : Character;
   376.    begin
   377.       validate_range_access(start_address, end_address);
   378.    word_loop:
   379.       for w in start_address .. end_address loop
   380.          if size mod bytes_per_sector = 0 then
   381.             if the_FD.locus.is_at_end_of_area = 1 then
   382.                -- Cannot transfer past the last sector in a seek area.
   383.                raise emulation_failure with "attempt to write past the end of a seek area";
   384.             end if;
   385.             this_sector := empty_sector;
   386.             get_next_sector(the_FD);
   387.             next := 0;
   388.          end if;
   389.          for c in KDF9.symbol_number'Range loop
   390.             next := next + 1;
   391.             char := this_sector(next);
   392.             store_symbol(CN_TR(char), w, c);
   393.             size := size + 1;
   394.          exit word_loop when reading_to_EM and char = E_M;
   395.          end loop;
   396.       end loop word_loop;
   397.       keep_house(the_FD, size, the_data_time);
   398.    end read;
   399.
   400.
   401.    procedure PIABCD (the_FD         : in out FD.device;
   402.                      Q_operand      : in KDF9.Q_register;
   403.                      set_offline    : in Boolean;
   404.                      transfer_to_EM,
   405.                      on_fixed_heads : in Boolean := False) is
   406.       switch_time, seek_time, latency_time, data_time : us;
   407.    begin
   408.       validate_device(the_FD, Q_operand);
   409.       validate_parity(the_FD);
   410.       -- Action the previously set-up seek (see PMA).
   411.       if on_fixed_heads then
   412.          switch_time := 0;
   413.          seek_time := 0;
   414.       else
   415.          select_new_seek_area(the_FD, switch_time, seek_time);
   416.       end if;
   417.       -- What about the drive number ??
   418.       set_the_sector_number(the_FD, Q_operand);
   419.       latency_time := latent_time(the_FD.locus.sector_number);
   420.       -- Read from the newly established position.
   421.       read(
   422.            the_FD,
   423.            Q_operand.I, Q_operand.M,
   424.            data_time,
   425.            reading_to_EM => transfer_to_EM
   426.           );
   427.       start_timed_transfer(
   428.                            the_FD,
   429.                            Q_operand,
   430.                            set_offline,
   431.                            switch_time + seek_time + latency_time + data_time
   432.                           );
   433.       the_FD.locus := updated_locus(the_FD, Q_operand);
   434.       set_lockouts(Q_operand);
   435.       update_statistics(
   436.                         the_FD,
   437.                         switch_time  => PIABCD.switch_time,
   438.                         seek_time    => PIABCD.seek_time,
   439.                         latency_time => PIABCD.latency_time,
   440.                         data_time    => PIABCD.data_time
   441.                        );
   442.    end PIABCD;
   443.
   444.    overriding
   445.    procedure PIA (the_FD      : in out FD.device;
   446.                   Q_operand   : in KDF9.Q_register;
   447.                   set_offline : in Boolean) is
   448.    begin
   449.       PIABCD(the_FD, Q_operand, set_offline);
   450.    end PIA;
   451.
   452.    overriding
   453.    procedure PIB (the_FD      : in out FD.device;
   454.                   Q_operand   : in KDF9.Q_register;
   455.                   set_offline : in Boolean) is
   456.    begin
   457.       PIABCD(the_FD, Q_operand, set_offline, transfer_to_EM => True);
   458.    end PIB;
   459.
   460.    overriding
   461.    procedure PIC (the_FD      : in out FD.device;
   462.                   Q_operand   : in KDF9.Q_register;
   463.                   set_offline : in Boolean) is
   464.    begin
   465.       PIABCD(the_FD, Q_operand, set_offline, on_fixed_heads => True);
   466.    end PIC;
   467.
   468.    overriding
   469.    procedure PID (the_FD      : in out FD.device;
   470.                   Q_operand   : in KDF9.Q_register;
   471.                   set_offline : in Boolean) is
   472.    begin
   473.       PIABCD(the_FD, Q_operand, set_offline, transfer_to_EM => True, on_fixed_heads => True);
   474.    end PID;
   475.
   476.    overriding
   477.    procedure PIE (the_FD      : in out FD.device;
   478.                   Q_operand   : in KDF9.Q_register;
   479.                   set_offline : in Boolean) is
   480.       pragma Unreferenced(set_offline);
   481.    begin
   482.       validate_transfer(the_FD, canonical(Q_operand));
   483.       raise NYI_trap;
   484.    end PIE;
   485.
   486.    overriding
   487.    procedure PIF (the_FD      : in out FD.device;
   488.                   Q_operand   : in KDF9.Q_register;
   489.                   set_offline : in Boolean) is
   490.       pragma Unreferenced(set_offline);
   491.    begin
   492.       validate_transfer(the_FD, canonical(Q_operand));
   493.       raise NYI_trap;
   494.    end PIF;
   495.
   496.    overriding
   497.    procedure PIG (the_FD      : in out FD.device;
   498.                   Q_operand   : in KDF9.Q_register;
   499.                   set_offline : in Boolean) is
   500.       pragma Unreferenced(set_offline);
   501.    begin
   502.       validate_transfer(the_FD, canonical(Q_operand));
   503.       raise NYI_trap;
   504.    end PIG;
   505.
   506.    overriding
   507.    procedure PIH (the_FD      : in out FD.device;
   508.                   Q_operand   : in KDF9.Q_register;
   509.                   set_offline : in Boolean) is
   510.       pragma Unreferenced(set_offline);
   511.    begin
   512.       validate_transfer(the_FD, canonical(Q_operand));
   513.       raise NYI_trap;
   514.    end PIH;
   515.
   516.    -- Set up, but do not effect, a seek to the locus specified by the Q_operand.
   517.    -- This follows advice from David Holdsworth that seeks were not effected
   518.    --    until a data transfer operation was obeyed.
   519.    overriding
   520.    procedure PMA (the_FD      : in out FD.device;
   521.                   Q_operand   : in KDF9.Q_register;
   522.                   set_offline : in Boolean) is
   523.    begin
   524.       validate_device(the_FD, Q_operand);
   525.       validate_parity(the_FD);
   526.       the_FD.target := locus_from(Q_operand);
   527.       start_timed_transfer(
   528.                            the_FD,
   529.                            Q_operand,
   530.                            set_offline,
   531.                            busy_time => 0,
   532.                            is_DMAing => False
   533.                           );
   534.    end PMA;
   535.
   536.    overriding
   537.    procedure PMB (the_FD      : in out FD.device;
   538.                   Q_operand   : in KDF9.Q_register;
   539.                   set_offline : in Boolean) is
   540.       pragma Unreferenced(set_offline);
   541.    begin
   542.       validate_device(the_FD, canonical(Q_operand));
   543.       validate_parity(the_FD);
   544.       null;
   545.    end PMB;
   546.
   547.    overriding
   548.    procedure PMC (the_FD      : in out FD.device;
   549.                   Q_operand   : in KDF9.Q_register;
   550.                   set_offline : in Boolean) is
   551.       pragma Unreferenced(set_offline);
   552.    begin
   553.       validate_device(the_FD, canonical(Q_operand));
   554.       validate_parity(the_FD);
   555.       null;
   556.    end PMC;
   557.
   558.    overriding
   559.    procedure PMD (the_FD      : in out FD.device;
   560.                   Q_operand   : in KDF9.Q_register;
   561.                   set_offline : in Boolean) is
   562.       pragma Unreferenced(set_offline);
   563.       null_locus : constant FD_layout.locus := (others => <>);
   564.    begin
   565.       validate_device(the_FD, canonical(Q_operand));
   566.       validate_parity(the_FD);
   567.       the_FD.comb := (others => 0);
   568.       the_FD.locus := null_locus;
   569.    end PMD;
   570.
   571.    overriding
   572.    procedure PMF (the_FD      : in out FD.device;
   573.                   Q_operand   : in KDF9.Q_register;
   574.                   set_offline : in Boolean) is
   575.       pragma Unreferenced(set_offline);
   576.    begin
   577.       validate_device(the_FD, canonical(Q_operand));
   578.       validate_parity(the_FD);
   579.       the_T_bit := the_FD.locus.is_at_end_of_area;
   580.    end PMF;
   581.
   582.    overriding
   583.    procedure PMG (the_FD      : in out FD.device;
   584.                   Q_operand   : in KDF9.Q_register;
   585.                   set_offline : in Boolean) is
   586.       pragma Unreferenced(set_offline);
   587.    begin
   588.       validate_device(the_FD, canonical(Q_operand));
   589.       validate_parity(the_FD);
   590.       LIV_if_user_mode;
   591.       raise NYI_trap;
   592.    end PMG;
   593.
   594.    overriding
   595.    procedure PMH (the_FD      : in out FD.device;
   596.                   Q_operand   : in KDF9.Q_register;
   597.                   set_offline : in Boolean) is
   598.       pragma Unreferenced(set_offline);
   599.    begin
   600.       validate_device(the_FD, canonical(Q_operand));
   601.       validate_parity(the_FD);
   602.       LIV_if_user_mode;
   603.       raise NYI_trap;
   604.    end PMH;
   605.
   606.    procedure put_next_sector (the_FD : in out FD.device) is
   607.       byte_address : constant POSIX.file_position := file_offset(the_FD.locus);
   608.    begin
   609.       if seek(fd_of(the_FD.stream), byte_address) /= byte_address then
   610.          raise emulation_failure with "seek failure in put_next_sector";
   611.       end if;
   612.       if write(fd_of(the_FD.stream), this_sector, bytes_per_sector) /= bytes_per_sector then
   613.          raise emulation_failure with "read failure in put_next_sector";
   614.       end if;
   615.       the_FD.sector_count := the_FD.sector_count + 1;
   616.       advance_the_sector_number(the_FD);
   617.       this_sector := empty_sector;
   618.    end put_next_sector;
   619.
   620.    procedure write (the_FD       : in out FD.device;
   621.                    start_address,
   622.                    end_address   : in KDF9.address;
   623.                    the_data_time : out us;
   624.                    writing_to_EM : in  Boolean := False) is
   625.       size   : KDF9.word := 0;
   626.       next   : Natural := 0;
   627.       symbol : KDF9.symbol;
   628.       char   : Character;
   629.    begin
   630.       validate_range_access(start_address, end_address);
   631.       if the_FD.locus.is_at_end_of_area = 1 then
   632.          -- Cannot transfer past the last sector in a seek area.
   633.          raise emulation_failure with "attempt to write past the end of a seek area";
   634.       end if;
   635.       this_sector := empty_sector;
   636.    word_loop:
   637.       for w in start_address .. end_address loop
   638.          for c in KDF9.symbol_number'Range loop
   639.             symbol := fetch_symbol(w, c);
   640.             char := TP_CN(symbol);
   641.             next := next + 1;
   642.             this_sector(next) := char;
   643.             size := size + 1;
   644.             exit when writing_to_EM and char = E_M;
   645.          end loop;
   646.          if (writing_to_EM and char = E_M) or size mod bytes_per_sector = 0 then
   647.             put_next_sector(the_FD);
   648.             next := 0;
   649.             -- Cannot transfer past the last sector in a seek area.
   650.          exit word_loop when the_FD.locus.is_at_end_of_area = 1 or
   651.                                 (writing_to_EM and char = E_M);
   652.          end if;
   653.       end loop word_loop;
   654.       if next > 0 then
   655.          -- Write out any untransferred residue of less than a sector.
   656.          put_next_sector(the_FD);
   657.       end if;
   658.       keep_house(the_FD, size, the_data_time);
   659.    end write;
   660.
   661.    procedure POABCD (the_FD           : in out FD.device;
   662.                        Q_operand      : in KDF9.Q_register;
   663.                        set_offline    : in Boolean;
   664.                        transfer_to_EM,
   665.                        on_fixed_heads : in Boolean := False) is
   666.       switch_time, seek_time, latency_time, data_time : us;
   667.    begin
   668.       validate_device(the_FD, Q_operand);
   669.       validate_parity(the_FD);
   670.       -- Action the previously set-up seek (see POA).
   671.       if on_fixed_heads then
   672.          switch_time := 0;
   673.          seek_time := 0;
   674.       else
   675.          select_new_seek_area(the_FD, switch_time, seek_time);
   676.       end if;
   677.       -- What about the drive number ??
   678.       set_the_sector_number(the_FD, Q_operand);
   679.       latency_time := latent_time(the_FD.locus.sector_number);
   680.       -- Write to the newly established position.
   681.       write(
   682.             the_FD,
   683.             Q_operand.I, Q_operand.M,
   684.             data_time,
   685.             writing_to_EM => transfer_to_EM
   686.            );
   687.       start_timed_transfer(
   688.                            the_FD,
   689.                            Q_operand,
   690.                            set_offline,
   691.                            switch_time + seek_time + latency_time + data_time
   692.                           );
   693.       set_lockouts(Q_operand);
   694.       the_FD.locus := updated_locus(the_FD, Q_operand);
   695.       update_statistics(
   696.                         the_FD,
   697.                         switch_time  => POABCD.switch_time,
   698.                         seek_time    => POABCD.seek_time,
   699.                         latency_time => POABCD.latency_time,
   700.                         data_time    => POABCD.data_time
   701.                        );
   702.    end POABCD;
   703.
   704.    overriding
   705.    procedure POA (the_FD      : in out FD.device;
   706.                   Q_operand   : in KDF9.Q_register;
   707.                   set_offline : in Boolean) is
   708.    begin
   709.       POABCD(the_FD, Q_operand, set_offline);
   710.    end POA;
   711.
   712.    overriding
   713.    procedure POB (the_FD      : in out FD.device;
   714.                   Q_operand   : in KDF9.Q_register;
   715.                   set_offline : in Boolean) is
   716.    begin
   717.       POABCD(the_FD, Q_operand, set_offline, transfer_to_EM => True);
   718.    end POB;
   719.
   720.    overriding
   721.    procedure POC (the_FD      : in out FD.device;
   722.                   Q_operand   : in KDF9.Q_register;
   723.                   set_offline : in Boolean) is
   724.    begin
   725.       POABCD(the_FD, Q_operand, set_offline, on_fixed_heads => True);
   726.    end POC;
   727.
   728.    overriding
   729.    procedure POD (the_FD      : in out FD.device;
   730.                   Q_operand   : in KDF9.Q_register;
   731.                   set_offline : in Boolean) is
   732.    begin
   733.       POABCD(the_FD, Q_operand, set_offline, transfer_to_EM => True, on_fixed_heads => True);
   734.    end POD;
   735.
   736.    overriding
   737.    procedure POE (the_FD      : in out FD.device;
   738.                   Q_operand   : in KDF9.Q_register;
   739.                   set_offline : in Boolean) is
   740.    begin
   741.       POC(the_FD, Q_operand, set_offline);
   742.    end POE;
   743.
   744.    overriding
   745.    procedure POF (the_FD      : in out FD.device;
   746.                   Q_operand   : in KDF9.Q_register;
   747.                   set_offline : in Boolean) is
   748.    begin
   749.       POA(the_FD, Q_operand, set_offline);
   750.    end POF;
   751.
   752.    overriding
   753.    procedure POG (the_FD      : in out FD.device;
   754.                   Q_operand   : in KDF9.Q_register;
   755.                   set_offline : in Boolean) is
   756.       pragma Unreferenced(set_offline);
   757.    begin
   758.       validate_transfer(the_FD, canonical(Q_operand));
   759.       raise NYI_trap;
   760.    end POG;
   761.
   762.    overriding
   763.    procedure POH (the_FD      : in out FD.device;
   764.                   Q_operand   : in KDF9.Q_register;
   765.                   set_offline : in Boolean) is
   766.       pragma Unreferenced(set_offline);
   767.    begin
   768.       validate_transfer(the_FD, canonical(Q_operand));
   769.       raise NYI_trap;
   770.    end POH;
   771.
   772.    overriding
   773.    procedure POK (the_FD      : in out FD.device;
   774.                   Q_operand   : in KDF9.Q_register;
   775.                   set_offline : in Boolean) is
   776.       pragma Unreferenced(set_offline);
   777.    begin
   778.       validate_transfer(the_FD, canonical(Q_operand));
   779.       raise NYI_trap;
   780.    end POK;
   781.
   782.    overriding
   783.    procedure POL (the_FD      : in out FD.device;
   784.                   Q_operand   : in KDF9.Q_register;
   785.                   set_offline : in Boolean) is
   786.       pragma Unreferenced(set_offline);
   787.    begin
   788.       validate_transfer(the_FD, canonical(Q_operand));
   789.       raise NYI_trap;
   790.    end POL;
   791.
   792.    FD_quantum : constant := 1E6 / 85E3;  -- 85_000 characters per second in the outer zone.
   793.
   794.    FD0 : aliased FD.device (number => FD0_number, kind => FD_kind, unit => 0,
   795.                             quantum => FD_quantum,
   796.                             is_slow => False);
   797.    pragma Unreferenced(FD0);
   798.
   799. end IOC.FD;

Compiling: ../Source\ioc-fd.ads
Source file time stamp: 2015-06-18 00:57:04
Compiled at: 2015-10-28 18:14:23

     1. -- ioc-fd.ads
     2. --
     3. -- Emulation of a fixed disc drive buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. private with FD_layout;
    20.
    21. package IOC.FD is
    22.
    23.    pragma Unsuppress(All_Checks);
    24.
    25.    type device is new IOC.device with private;
    26.
    27.    subtype disc is FD.device;
    28.
    29.    overriding
    30.    procedure PIA (the_FD      : in out FD.device;
    31.                   Q_operand   : in KDF9.Q_register;
    32.                   set_offline : in Boolean);
    33.    overriding
    34.    procedure PIB (the_FD      : in out FD.device;
    35.                   Q_operand   : in KDF9.Q_register;
    36.                   set_offline : in Boolean);
    37.    overriding
    38.    procedure PIC (the_FD      : in out FD.device;
    39.                   Q_operand   : in KDF9.Q_register;
    40.                   set_offline : in Boolean);
    41.    overriding
    42.    procedure PID (the_FD      : in out FD.device;
    43.                   Q_operand   : in KDF9.Q_register;
    44.                   set_offline : in Boolean);
    45.    overriding
    46.    procedure PIE (the_FD      : in out FD.device;
    47.                   Q_operand   : in KDF9.Q_register;
    48.                   set_offline : in Boolean);
    49.    overriding
    50.    procedure PIF (the_FD      : in out FD.device;
    51.                   Q_operand   : in KDF9.Q_register;
    52.                   set_offline : in Boolean);
    53.    overriding
    54.    procedure PIG (the_FD      : in out FD.device;
    55.                   Q_operand   : in KDF9.Q_register;
    56.                   set_offline : in Boolean);
    57.    overriding
    58.    procedure PIH (the_FD      : in out FD.device;
    59.                   Q_operand   : in KDF9.Q_register;
    60.                   set_offline : in Boolean);
    61.
    62.    overriding
    63.    procedure PMA (the_FD      : in out FD.device;
    64.                   Q_operand   : in KDF9.Q_register;
    65.                   set_offline : in Boolean);
    66.    overriding
    67.    procedure PMB (the_FD      : in out FD.device;
    68.                   Q_operand   : in KDF9.Q_register;
    69.                   set_offline : in Boolean);
    70.    overriding
    71.    procedure PMC (the_FD      : in out FD.device;
    72.                   Q_operand   : in KDF9.Q_register;
    73.                   set_offline : in Boolean);
    74.    overriding
    75.    procedure PMD (the_FD      : in out FD.device;
    76.                   Q_operand   : in KDF9.Q_register;
    77.                   set_offline : in Boolean);
    78.    overriding
    79.    procedure PMF (the_FD      : in out FD.device;
    80.                   Q_operand   : in KDF9.Q_register;
    81.                   set_offline : in Boolean);
    82.    overriding
    83.    procedure PMG (the_FD      : in out FD.device;
    84.                   Q_operand   : in KDF9.Q_register;
    85.                   set_offline : in Boolean);
    86.    overriding
    87.    procedure PMH (the_FD      : in out FD.device;
    88.                   Q_operand   : in KDF9.Q_register;
    89.                   set_offline : in Boolean);
    90.
    91.    overriding
    92.    procedure POA (the_FD      : in out FD.device;
    93.                   Q_operand   : in KDF9.Q_register;
    94.                   set_offline : in Boolean);
    95.    overriding
    96.    procedure POB (the_FD      : in out FD.device;
    97.                   Q_operand   : in KDF9.Q_register;
    98.                   set_offline : in Boolean);
    99.    overriding
   100.    procedure POC (the_FD      : in out FD.device;
   101.                   Q_operand   : in KDF9.Q_register;
   102.                   set_offline : in Boolean);
   103.    overriding
   104.    procedure POD (the_FD      : in out FD.device;
   105.                   Q_operand   : in KDF9.Q_register;
   106.                   set_offline : in Boolean);
   107.    overriding
   108.    procedure POE (the_FD      : in out FD.device;
   109.                   Q_operand   : in KDF9.Q_register;
   110.                   set_offline : in Boolean);
   111.    overriding
   112.    procedure POF (the_FD      : in out FD.device;
   113.                   Q_operand   : in KDF9.Q_register;
   114.                   set_offline : in Boolean);
   115.    overriding
   116.    procedure POG (the_FD      : in out FD.device;
   117.                   Q_operand   : in KDF9.Q_register;
   118.                   set_offline : in Boolean);
   119.    overriding
   120.    procedure POH (the_FD      : in out FD.device;
   121.                   Q_operand   : in KDF9.Q_register;
   122.                   set_offline : in Boolean);
   123.    overriding
   124.    procedure POK (the_FD      : in out FD.device;
   125.                   Q_operand   : in KDF9.Q_register;
   126.                   set_offline : in Boolean);
   127.    overriding
   128.    procedure POL (the_FD      : in out FD.device;
   129.                   Q_operand   : in KDF9.Q_register;
   130.                   set_offline : in Boolean);
   131.
   132. private
   133.
   134.    use FD_layout;
   135.
   136.    -- The disc storage is actually implemented in an external file.
   137.    -- The comb and locus variables shadow the physical state of the drive.
   138.    -- They are used to derive a file address from the position established
   139.    --    by seeks and transfer operations.
   140.
   141.    type comb_data is array (FD_layout.platter_number)
   142.                   of FD_layout.seek_area_number;
   143.    type disc_data is array (FD_layout.platter_number, FD_layout.seek_area_number)
   144.                   of FD_layout.track_set;
   145.
   146.    type device is new IOC.device with
   147.       record
   148.          comb               : FD.comb_data := (others => 0);
   149.          locus,
   150.          target             : FD_layout.locus;
   151.          switch_time,
   152.          seek_time,
   153.          latency_time,
   154.          data_time,
   155.          last_time,
   156.          elapsed_time_total : KDF9.microseconds := 0;
   157.          seek_count,
   158.          latency_count,
   159.          sector_count,
   160.          byte_count         : KDF9.word := 0;
   161.       end record;
   162.
   163.    overriding
   164.    procedure Initialize (the_FD : in out FD.device);
   165.
   166.    overriding
   167.    procedure Finalize (the_FD : in out FD.device);
   168.
   169.    overriding
   170.    function usage (the_FD : FD.device)
   171.    return KDF9.word;
   172.
   173.    overriding
   174.    function IO_elapsed_time_total (the_FD : FD.device)
   175.    return KDF9.microseconds;
   176.
   177. end IOC.FD;

 799 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-lp.adb
Source file time stamp: 2015-06-18 00:56:30
Compiled at: 2015-10-28 18:14:26

     1. -- ioc-lp.adb
     2. --
     3. -- Emulation of a lineprinter buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with IOC; pragma Elaborate_All(IOC);
    20. with KDF9.store;
    21.
    22. use  KDF9.store;
    23.
    24. package body IOC.LP is
    25.
    26.    pragma Unsuppress(All_Checks);
    27.
    28.    overriding
    29.    procedure Initialize (the_LP : in out LP.device) is
    30.    begin
    31.       open(the_LP, write_mode, attaching => False);
    32.    end Initialize;
    33.
    34.    overriding
    35.    procedure Finalize (the_LP : in out LP.device) is
    36.    begin
    37.       close(the_LP, "printed", the_LP.unit_count, "line(s)");
    38.    end Finalize;
    39.
    40.    max_LP_line_length : constant := 160;
    41.
    42.    procedure do_output_housekeeping (the_LP   : in out LP.device;
    43.                                     old_count,
    44.                                     fetched  : in KDF9.word) is
    45.    begin
    46.       flush(the_LP.stream);
    47.       correct_transfer_time(the_LP, IO_elapsed_time(the_LP, the_LP.unit_count-old_count));
    48.       add_in_the_IO_CPU_time(the_LP, fetched);
    49.    end do_output_housekeeping;
    50.
    51.    procedure put_symbols (the_LP        : in out LP.device;
    52.                           Q_operand     : in KDF9.Q_register;
    53.                           writing_to_EM : in Boolean) is
    54.       start_address : constant KDF9.address := Q_operand.I;
    55.       end_address   : constant KDF9.address := Q_operand.M;
    56.       count         : constant KDF9.word := the_LP.unit_count;
    57.       size   : KDF9.word := 0;
    58.       next   : Natural := 0;
    59.       symbol : KDF9.symbol;
    60.       char   : Character;
    61.    begin
    62.       validate_range_access(start_address, end_address);
    63.    word_loop:
    64.       -- What should happen if transfer length > max_LP_line_length characters ??
    65.       for w in start_address .. end_address loop
    66.          for c in KDF9.symbol_number'Range loop
    67.             exit word_loop when next > max_LP_line_length;
    68.             symbol := fetch_symbol(w, c);
    69.             size := size + 1;
    70.             exit word_loop when writing_to_EM and symbol = KDF9.End_Message;
    71.             char := to_LP(symbol);
    72.             if char /= KDF9.W_F then
    73.                next := next + 1;
    74.                put_char(char, the_LP.stream);
    75.                if symbol = KDF9.Line_Shift or symbol = KDF9.Page_Change then
    76.                   the_LP.unit_count := the_LP.unit_count + 1;
    77.                   flush(the_LP.stream);
    78.                   next := 0;
    79.                end if;
    80.             end if;
    81.          end loop;
    82.       end loop word_loop;
    83.       do_output_housekeeping(the_LP, old_count => count, fetched => size);
    84.    end put_symbols;
    85.
    86.    -- LPQq
    87.    overriding
    88.    procedure POA (the_LP      : in out LP.device;
    89.                   Q_operand   : in KDF9.Q_register;
    90.                   set_offline : in Boolean) is
    91.    begin
    92.       initialize_byte_mode_transfer(the_LP, Q_operand, set_offline);
    93.       put_symbols(the_LP, Q_operand, writing_to_EM => False);
    94.       set_lockouts(Q_operand);
    95.    end POA;
    96.
    97.    -- LPEQq
    98.    overriding
    99.    procedure POB (the_LP      : in out LP.device;
   100.                   Q_operand   : in KDF9.Q_register;
   101.                   set_offline : in Boolean) is
   102.    begin
   103.       initialize_byte_mode_transfer(the_LP, Q_operand, set_offline);
   104.       put_symbols(the_LP, Q_operand, writing_to_EM => True);
   105.       set_lockouts(Q_operand);
   106.    end POB;
   107.
   108.    procedure put_words (the_LP        : in out LP.device;
   109.                         Q_operand     : in KDF9.Q_register;
   110.                         writing_to_EM : in Boolean) is
   111.       start_address : constant KDF9.address := Q_operand.I;
   112.       end_address   : constant KDF9.address := Q_operand.M;
   113.       count         : constant KDF9.word := the_LP.unit_count;
   114.       size   : KDF9.word := 0;
   115.       next   : Natural := 0;
   116.       symbol : KDF9.symbol;
   117.       char   : Character;
   118.    begin
   119.       validate_range_access(start_address, end_address);
   120.       -- What should happen if transfer length > max_LP_line_length characters ??
   121.       for w in start_address .. end_address loop
   122.          exit when next > max_LP_line_length;
   123.          symbol := KDF9.symbol(fetch_word(w) and 8#77#);
   124.          size := size + 1;
   125.          exit when writing_to_EM and symbol = KDF9.End_Message;
   126.          char := to_LP(symbol);
   127.          if char /= KDF9.W_F then
   128.             next := next + 1;
   129.             put_char(char, the_LP.stream);
   130.             if symbol = KDF9.Line_Shift or symbol = KDF9.Page_Change then
   131.                the_LP.unit_count := the_LP.unit_count + 1;
   132.                flush(the_LP.stream);
   133.                next := 0;
   134.             end if;
   135.          end if;
   136.       end loop;
   137.       do_output_housekeeping(the_LP, old_count => count, fetched => size);
   138.    end put_words;
   139.
   140.    -- Character write ?? Usercode Digest and Manual conflict!
   141.    overriding
   142.    procedure POC (the_LP      : in out LP.device;
   143.                   Q_operand   : in KDF9.Q_register;
   144.                   set_offline : in Boolean) is
   145.    begin
   146.       initialize_byte_mode_transfer(the_LP, Q_operand, set_offline);
   147.       put_words(the_LP, Q_operand, writing_to_EM => False);
   148.       set_lockouts(Q_operand);
   149.    end POC;
   150.
   151.    -- Character write to End_Message ?? Usercode Digest and Manual conflict!
   152.    overriding
   153.    procedure POD (the_LP      : in out LP.device;
   154.                   Q_operand   : in KDF9.Q_register;
   155.                   set_offline : in Boolean) is
   156.    begin
   157.       initialize_byte_mode_transfer(the_LP, Q_operand, set_offline);
   158.       put_words(the_LP, Q_operand, writing_to_EM => True);
   159.       set_lockouts(Q_operand);
   160.    end POD;
   161.
   162.    LP_quantum : constant := 1E6 / (900 / 60);  -- 900 lines per minute.
   163.
   164.    LP0 : aliased LP.device (number  => LP0_number,
   165.                             kind    => LP_kind,
   166.                             unit    => 0,
   167.                             quantum => LP_quantum,
   168.                             is_slow => True);
   169.    pragma Unreferenced(LP0);
   170.
   171. end IOC.LP;

Compiling: ../Source\ioc-lp.ads
Source file time stamp: 2015-06-18 00:56:28
Compiled at: 2015-10-28 18:14:26

     1. -- ioc-lp.ads
     2. --
     3. -- Emulation of a lineprinter buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package IOC.LP is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    type device is new IOC.unit_record_device with private;
    24.
    25.    -- LPQq
    26.    overriding
    27.    procedure POA (the_LP      : in out LP.device;
    28.                   Q_operand   : in KDF9.Q_register;
    29.                   set_offline : in Boolean);
    30.    -- LPEQq
    31.    overriding
    32.    procedure POB (the_LP      : in out LP.device;
    33.                   Q_operand   : in KDF9.Q_register;
    34.                   set_offline : in Boolean);
    35.    -- Character write ??
    36.    overriding
    37.    procedure POC (the_LP      : in out LP.device;
    38.                   Q_operand   : in KDF9.Q_register;
    39.                   set_offline : in Boolean);
    40.    -- Character write to End_Message ??
    41.    overriding
    42.    procedure POD (the_LP      : in out LP.device;
    43.                   Q_operand   : in KDF9.Q_register;
    44.                   set_offline : in Boolean);
    45.
    46. private
    47.
    48.    type device is new IOC.unit_record_device with null record;
    49.
    50.    overriding
    51.    procedure Initialize (the_LP : in out LP.device);
    52.
    53.    overriding
    54.    procedure Finalize (the_LP : in out LP.device);
    55.
    56. end IOC.LP;

 171 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-magtape.adb
Source file time stamp: 2015-06-18 00:56:26
Compiled at: 2015-10-28 18:14:28

     1. -- ioc-magtape.adb
     2. --
     3. -- Emulation of magnetic tape buffer commonalities.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with exceptions;
    20. with formatting;
    21. with IOC;
    22. with settings;
    23.
    24. use  exceptions;
    25. use  formatting;
    26. use  settings;
    27.
    28. package body IOC.magtape is
    29.
    30.    pragma Unsuppress(All_Checks);
    31.
    32.    use MT_brick_IO;
    33.
    34.    function is_open (tape : in magtape.file)
    35.    return Boolean is
    36.    begin
    37.       return Is_Open(tape.reel);
    38.    end is_open;
    39.
    40.    procedure open_RW (tape : in out magtape.file;
    41.                       name : in String) is
    42.    begin
    43.       Open(tape.reel, Inout_File, name);
    44.    exception
    45.       when others =>
    46.          Create(tape.reel, Inout_File, name);
    47.    end open_RW;
    48.
    49.    procedure open_RO (tape : in out magtape.file;
    50.                       name : in String) is
    51.    begin
    52.       Open(tape.reel, In_File, name);
    53.    end open_RO;
    54.
    55.    procedure close (tape : in out magtape.file) is
    56.    begin
    57.       Close(tape.reel);
    58.    end close;
    59.
    60.    procedure write (tape  : in magtape.file;
    61.                     index : in KDF9.word;
    62.                     stuff : in IOC.magtape.brick) is
    63.    begin
    64.       Write(tape.reel, stuff, to => Positive_Count(index));
    65.    exception
    66.       when End_Error =>
    67.          raise end_of_tape;
    68.    end write;
    69.
    70.    procedure read (tape  : in magtape.file;
    71.                    index : in KDF9.word;
    72.                    stuff : out IOC.magtape.brick) is
    73.    begin
    74.       Read(tape.reel, stuff, from => Positive_Count(index));
    75.    exception
    76.       when End_Error =>
    77.          raise end_of_tape;
    78.    end read;
    79.
    80.    overriding
    81.    procedure Initialize (the_deck : in out magtape.deck) is
    82.    begin
    83.       the_deck.device_name := logical_device_name_of(the_deck);
    84.       open(the_deck);
    85.       if not the_deck.is_open then
    86.             output_line(the_deck.device_name
    87.                       & " is on buffer #"
    88.                       & oct_of(KDF9.Q_part(the_deck.number), 2)
    89.                       & ", but no tape was mounted!");
    90.          the_deck.is_abnormal := True;
    91.          the_deck.is_offline  := True;
    92.       elsif not the_deck.has_a_WP_ring then
    93.             output_line(the_deck.device_name
    94.                       & ", on buffer #"
    95.                       & oct_of(KDF9.Q_part(the_deck.number), 2)
    96.                       & ", does not have a Write Permit Ring.");
    97.       end if;
    98.       IOC.device(the_deck).Initialize;
    99.    end Initialize;
   100.
   101.    overriding
   102.    procedure Finalize (the_deck : in out magtape.deck) is
   103.    begin
   104.       if the_deck.is_open then
   105.          if the_deck.usage /= 0 and the_final_state_is_wanted then
   106.             output_line(the_deck.device_name
   107.                       & " on buffer #"
   108.                       & oct_of(KDF9.Q_part(the_deck.number), 2)
   109.                       & optional(the_deck.is_at_BOT,
   110.                                  " is at BOT",
   111.                                  optional(the_deck.is_at_ETW,
   112.                                           " is at ETW",
   113.                                           " is at gap" & KDF9.word'Image(the_deck.brick_number)
   114.                                          )
   115.                                 )
   116.                       & ", after"
   117.                       & KDF9.word'Image(the_deck.gaps_crossed)
   118.                       & " inter-block gap(s) and"
   119.                       & KDF9.word'Image(the_deck.usage)
   120.                       & " character(s).");
   121.          end if;
   122.          close(the_deck.tape);
   123.       end if;
   124.    exception
   125.       when others =>
   126.          output_line("Finalize error for buffer #"
   127.                    & oct_of(KDF9.Q_part(the_deck.number))
   128.                    & "; ");
   129.          raise;
   130.    end Finalize;
   131.
   132.    function as_word (the_serial : String)
   133.    return KDF9.word is
   134.       word : KDF9.word := 0;
   135.    begin
   136.       for b in the_serial'Range loop
   137.          word := (word * 2**6) or KDF9.word(CN_TR(the_serial(b)));
   138.       end loop;
   139.       return word;
   140.    end as_word;
   141.
   142.    procedure find_tape_labelled (the_label  : in magtape.short_label;
   143.                                  its_number : out KDF9.buffer_number;
   144.                                  its_serial : out KDF9.word) is
   145.       the_brick : IOC.magtape.brick;
   146.    begin
   147.       for t in KDF9.buffer_number loop
   148.          if is_unallocated(buffer(t))                and then
   149.                buffer(t).kind = MT_kind              and then
   150.                   is_at_BOT(magtape.deck(buffer(t).all)) then
   151.             --read the label
   152.             begin
   153.                read(magtape.deck(buffer(t).all).tape, 1, the_brick);
   154.                if the_brick.kind = MT_data_brick               and then
   155.                     the_brick.data'Length >= 16                and then
   156.                        the_brick.data(9 .. 16) = String(the_label) then
   157.                   its_number := t;
   158.                   its_serial := as_word(the_brick.data(1 .. 8));
   159.                   return;
   160.                end if;
   161.             exception
   162.                when end_of_tape =>
   163.                   -- Treat empty tapes and zero labels specially for now!
   164.                   if String(the_label) = (9 .. 16 => ' ') then
   165.                      its_number := t;
   166.                      its_serial := 0;
   167.                      return;
   168.                   end if;
   169.                   null;
   170.                when others =>
   171.                   null;
   172.             end;
   173.          end if;
   174.       end loop;
   175.       trap_invalid_instruction("no such MT as '" & String(the_label) & "' is mounted");
   176.    end find_tape_labelled;
   177.
   178.    procedure find_tape_labelled (the_label  : in magtape.long_label;
   179.                                  its_number : out KDF9.buffer_number;
   180.                                  its_serial : out KDF9.word) is
   181.       the_brick : IOC.magtape.brick;
   182.    begin
   183.       for t in KDF9.buffer_number loop
   184.          if is_unallocated(buffer(t))                and then
   185.                buffer(t).kind = MT_kind              and then
   186.                   is_at_BOT(magtape.deck(buffer(t).all)) then
   187.             --read the label
   188.             begin
   189.                read(magtape.deck(buffer(t).all).tape, 1, the_brick);
   190.                if the_brick.kind = MT_data_brick               and then
   191.                     the_brick.data'Length >= 24                and then
   192.                        the_brick.data(9 .. 24) = String(the_label) then
   193.                   its_number := t;
   194.                   its_serial := as_word(the_brick.data(1 .. 8));
   195.                   return;
   196.                end if;
   197.             exception
   198.                when end_of_tape =>
   199.                   -- Treat empty tapes and zero labels specially for now!
   200.                   if String(the_label) = (9 .. 24 => ' ') then
   201.                      its_number := t;
   202.                      its_serial := 0;
   203.                      return;
   204.                   end if;
   205.                   null;
   206.                when others =>
   207.                   null;
   208.             end;
   209.          end if;
   210.       end loop;
   211.       trap_invalid_instruction("no such MT as '" & String(the_label) & "' is mounted");
   212.    end find_tape_labelled;
   213.
   214.    procedure open (the_deck : in out magtape.deck) is
   215.    begin
   216.       the_deck.has_a_WP_ring := False;
   217.       the_deck.tape.open_RW(the_deck.device_name);
   218.       the_deck.has_a_WP_ring := True;
   219.    exception
   220.       when MT_brick_IO.Use_Error =>
   221.          the_deck.tape.open_RO(the_deck.device_name);
   222.    end open;
   223.
   224.    overriding
   225.    function is_open (the_deck : magtape.deck)
   226.    return Boolean is
   227.    begin
   228.       return the_deck.tape.is_open;
   229.    end is_open;
   230.
   231.    overriding
   232.    function usage (the_deck : magtape.deck)
   233.    return KDF9.word is
   234.    begin
   235.       return the_deck.bytes_moved;
   236.    end usage;
   237.
   238.    overriding
   239.    procedure close (the_deck : in out magtape.deck) is
   240.    begin
   241.       the_deck.tape.close;
   242.    end close;
   243.
   244.    not overriding
   245.    function is_at_BOT (the_deck : magtape.deck)
   246.    return Boolean is
   247.    begin
   248.       return the_deck.is_open and then
   249.                 the_deck.brick_number = 0;
   250.    end is_at_BOT;
   251.
   252.    the_ETW_position : constant := 10_000;
   253.
   254.    not overriding
   255.    function is_at_ETW (the_deck : magtape.deck)
   256.    return Boolean is  -- STUB
   257.    begin
   258.       return the_deck.is_open and then
   259.                 the_deck.brick_number >= the_ETW_position;
   260.    end is_at_ETW;
   261.
   262.    not overriding
   263.    function is_at_LBM (the_deck : magtape.deck)
   264.    return Boolean is
   265.    begin
   266.       return the_deck.is_open and then
   267.                 the_deck.is_LBM_flagged;
   268.    end is_at_LBM;
   269.
   270.    procedure bump (word_address : in out KDF9.address; symbol_nr : in out KDF9.symbol_number) is
   271.    begin
   272.       if symbol_nr < 7 then
   273.          symbol_nr := symbol_nr + 1;
   274.       else
   275.          symbol_nr := 0;
   276.          word_address := word_address + 1;
   277.       end if;
   278.    end bump;
   279.
   280.    -- See Manual §22.1.2, p.178, ¶2.
   281.    gap_length  : constant KDF9.word := 140;
   282.
   283.    function tape_traversal_time (the_deck : magtape.deck;
   284.                                  gaps_crossed, erased_length : KDF9.word)
   285.    return KDF9.microseconds is
   286.    begin
   287.       return the_deck.quantum
   288.            * KDF9.microseconds(gaps_crossed * gap_length + erased_length);
   289.    end tape_traversal_time;
   290.
   291.    function data_transfer_time (the_deck   : magtape.deck;
   292.                                 byte_count : KDF9.word)
   293.    return KDF9.microseconds is
   294.    begin
   295.       return the_deck.quantum * KDF9.microseconds(byte_count);
   296.    end data_transfer_time;
   297.
   298.    overriding
   299.    function IO_elapsed_time_total (the_deck : magtape.deck)
   300.    return KDF9.microseconds is
   301.    begin
   302.       return the_deck.elapsed_time_total;
   303.    end IO_elapsed_time_total;
   304.
   305.    procedure update_statistics (the_deck : in out magtape.deck;
   306.                                 gaps_crossed,
   307.                                 erased_length,
   308.                                 bytes_moved : in KDF9.word) is
   309.       real_time : KDF9.microseconds;
   310.    begin
   311.       the_deck.gaps_crossed := the_deck.gaps_crossed + gaps_crossed;
   312.       the_deck.erased_length := the_deck.erased_length + erased_length;
   313.       the_deck.bytes_moved := the_deck.bytes_moved + bytes_moved;
   314.       real_time := tape_traversal_time(the_deck, gaps_crossed, erased_length)
   315.                  + data_transfer_time(the_deck, bytes_moved);
   316.       the_deck.elapsed_time_total := the_deck.elapsed_time_total + real_time;
   317.       add_in_the_IO_CPU_time(the_deck, bytes_moved);
   318.       correct_transfer_time(the_deck, real_time);
   319.    end update_statistics;
   320.
   321.    procedure get_tape_brick (the_deck  : in out magtape.deck;
   322.                              the_brick : out IOC.magtape.brick;
   323.                              backwards : in Boolean := False) is
   324.    begin
   325.       the_deck.is_LBM_flagged := False;
   326.       if not backwards then
   327.          the_deck.brick_number := the_deck.brick_number + 1;
   328.       end if;
   329.       read(the_deck.tape, the_deck.brick_number, the_brick);
   330.       if backwards then
   331.          the_deck.brick_number := the_deck.brick_number - 1;
   332.       end if;
   333.       case the_brick.kind is
   334.          when MT_data_brick =>
   335.             update_statistics(the_deck, 1, 0, KDF9.word(the_brick.size));
   336.          when MT_mark_brick =>
   337.             update_statistics(the_deck, 1, 0, 0);
   338.          when MT_erased_brick =>
   339.             update_statistics(the_deck, 1, the_brick.erased_length, 0);
   340.       end case;
   341.    end get_tape_brick;
   342.
   343.    procedure get_next_data_brick (the_deck  : in out magtape.deck;
   344.                                   the_brick : out IOC.magtape.brick) is
   345.    begin
   346.       loop
   347.          get_tape_brick(the_deck, the_brick);
   348.       exit when the_brick.kind = MT_data_brick or the_deck.is_abnormal;
   349.       end loop;
   350.       the_deck.is_LBM_flagged := the_brick.is_LBM_flagged;
   351.    end get_next_data_brick;
   352.
   353.    procedure get_prev_data_brick (the_deck  : in out magtape.deck;
   354.                                   the_brick : out IOC.magtape.brick) is
   355.    begin
   356.       loop
   357.          get_tape_brick(the_deck, the_brick, backwards => True);
   358.       exit when the_brick.kind = MT_data_brick;
   359.       end loop;
   360.       the_deck.is_LBM_flagged := the_brick.is_LBM_flagged;
   361.    end get_prev_data_brick;
   362.
   363.    procedure read_block (the_deck       : in out magtape.deck;
   364.                          Q_operand      : in KDF9.Q_register;
   365.                          reading_to_EM  : in Boolean := False) is
   366.       start_address : constant KDF9.address := Q_operand.I;
   367.       end_address   : constant KDF9.address := Q_operand.M;
   368.       w         : KDF9.address := start_address;
   369.       s         : KDF9.symbol_number := 0;
   370.       the_brick : IOC.magtape.brick;
   371.       the_last  : Positive;
   372.    begin
   373.       validate_range_access(start_address, end_address);
   374.       get_next_data_brick(the_deck, the_brick);
   375.       -- Disregard an incomplete final word; see Manual §22.1.5, p184, ¶2.
   376.       if the_brick.data'Length mod 8 = 0 then
   377.          the_last := the_brick.data'Last;
   378.       else
   379.          the_deck.is_abnormal := True;
   380.          the_last := the_brick.data'Last - the_brick.data'Length mod 8;
   381.       end if;
   382.       -- Set the_last to the end of the earliest word containing End_Message,
   383.       --    if such exists; else leave the_last unchanged.
   384.       if reading_to_EM then
   385.          to_locate_any_EM:
   386.             for i in 1 .. the_last loop
   387.                if the_brick.data(i) = KDF9.E_M then
   388.                   the_last := i - i mod 8 + 8;
   389.                   exit to_locate_any_EM;
   390.                end if;
   391.             end loop to_locate_any_EM;
   392.       end if;
   393.       -- Store the relevant words.
   394.       for i in 1 .. the_last loop
   395.          store_symbol(CN_TR(the_brick.data(i)), w, s);
   396.       exit when (w = end_address) and (s = 7);
   397.          bump(w, s);
   398.       end loop;
   399.    exception
   400.       when end_of_tape =>
   401.          the_deck.is_abnormal := True;
   402.          trap_invalid_instruction("attempt to read past ETW at brick"
   403.                                 & KDF9.word'Image(the_deck.brick_number)
   404.                                 & " of "
   405.                                 & the_deck.device_name);
   406.    end read_block;
   407.
   408.    procedure read_block_backwards (the_deck       : in out magtape.deck;
   409.                                    Q_operand      : in KDF9.Q_register;
   410.                                    reading_to_EM  : in Boolean := False) is
   411.       start_address : constant KDF9.address := Q_operand.I;
   412.       end_address   : constant KDF9.address := Q_operand.M;
   413.       w         : KDF9.address := start_address;
   414.       s         : KDF9.symbol_number := 0;
   415.       the_brick : IOC.magtape.brick;
   416.       the_first : Positive;
   417.    begin
   418.       validate_range_access(start_address, end_address);
   419.       get_prev_data_brick(the_deck, the_brick);
   420.       -- Disregard an incomplete initial word; see Manual §22.1.5, p184, ¶2.
   421.       if the_brick.data'Length mod 8 = 0 then
   422.          the_first := the_brick.data'First;
   423.       else
   424.          the_deck.is_abnormal := True;
   425.          the_first := the_brick.data'First + the_brick.data'Length mod 8;
   426.       end if;
   427.       -- Set the_first to the start of the latest word containing End_Message,
   428.       --    if such exists; else leave the_first unchanged.
   429.       if reading_to_EM then
   430.          to_locate_any_EM:
   431.             for i in reverse the_first .. the_brick.data'Last loop
   432.                if the_brick.data(i) = KDF9.E_M then
   433.                   the_first := i - i mod 8 + 1;
   434.                   exit to_locate_any_EM;
   435.                end if;
   436.             end loop to_locate_any_EM;
   437.       end if;
   438.       -- Store the relevant words.
   439.       for i in the_first .. the_brick.data'Last loop
   440.          store_symbol(CN_TR(the_brick.data(i)), w, s);
   441.       exit when (w = end_address) and (s = 7);
   442.          bump(w, s);
   443.       end loop;
   444.       -- And reverse them.
   445.       mirror(start_address, w);
   446.    exception
   447.       when end_of_tape =>
   448.          the_deck.is_abnormal := True;
   449.          raise end_of_tape with "when reading past brick"
   450.                               & KDF9.word'Image(the_deck.brick_number)
   451.                               & " of "
   452.                               & the_deck.device_name;
   453.    end read_block_backwards;
   454.
   455.    procedure put_next_data_brick (the_deck  : in out magtape.deck;
   456.                                   the_data  : in String;
   457.                                   is_last   : in Boolean := False) is
   458.       the_brick : constant IOC.magtape.brick := (kind => MT_data_brick,
   459.                                                  size => the_data'Length,
   460.                                                  data => the_data,
   461.                                                  is_LBM_flagged => is_last);
   462.    begin
   463.       if not the_deck.has_a_WP_ring then
   464.          trap_invalid_instruction("attempt to write a read-only tape");
   465.       end if;
   466.       the_deck.is_LBM_flagged := False;
   467.       the_deck.brick_number := the_deck.brick_number + 1;
   468.       write(the_deck.tape, the_deck.brick_number, the_brick);
   469.       update_statistics(the_deck, 1, 0, KDF9.word(the_data'Length));
   470.    exception
   471.       when end_of_tape =>
   472.          the_deck.is_abnormal := True;
   473.          trap_invalid_instruction("attempt to write past ETW at brick"
   474.                                 & KDF9.word'Image(the_deck.brick_number)
   475.                                 & " of "
   476.                                 & the_deck.device_name);
   477.    end put_next_data_brick;
   478.
   479.    procedure write (the_deck       : in out magtape.deck;
   480.                     Q_operand      : in KDF9.Q_register;
   481.                     is_LBM_flagged : in Boolean := False) is
   482.       start_address : constant KDF9.address := Q_operand.I;
   483.       end_address   : constant KDF9.address := Q_operand.M;
   484.    begin
   485.       validate_range_access(start_address, end_address);
   486.       declare
   487.          next_byte : Positive := 1;
   488.          the_data  : String(1 .. Positive(end_address-start_address+1)*8);
   489.       begin
   490.       word_loop:
   491.          for w in start_address .. end_address loop
   492.             for c in KDF9.symbol_number'Range loop
   493.                the_data(next_byte) := TP_CN(fetch_symbol(w, c));
   494.                next_byte := next_byte + 1;
   495.             end loop;
   496.          end loop word_loop;
   497.          put_next_data_brick(the_deck, the_data, is_LBM_flagged);
   498.       end;
   499.    end write;
   500.
   501.    procedure write_to_EM (the_deck       : in out magtape.deck;
   502.                           Q_operand      : in KDF9.Q_register;
   503.                           is_LBM_flagged : in Boolean := False) is
   504.       start_address : constant KDF9.address := Q_operand.I;
   505.       end_address   : constant KDF9.address := Q_operand.M;
   506.    begin
   507.       validate_range_access(start_address, end_address);
   508.       declare
   509.          next_byte : Positive := 1;
   510.          EM_found  : Boolean := False;
   511.          the_data  : String(1 .. Positive(end_address-start_address+1)*8);
   512.          symbol    : KDF9.symbol;
   513.       begin
   514.       word_loop:
   515.          for w in start_address .. end_address loop
   516.             for c in KDF9.symbol_number'Range loop
   517.                symbol := fetch_symbol(w, c);
   518.                EM_found := EM_found or (symbol = KDF9.End_Message);
   519.                the_data(next_byte) := TP_CN(symbol);
   520.                next_byte := next_byte + 1;
   521.             end loop;
   522.          exit word_loop when EM_found;
   523.          end loop word_loop;
   524.          put_next_data_brick(the_deck, the_data(1 .. next_byte-1), is_LBM_flagged);
   525.       end;
   526.    end write_to_EM;
   527.
   528.    procedure skip_forwards (the_deck     : in out magtape.deck;
   529.                             gaps_crossed : in KDF9.word) is
   530.       the_brick  : IOC.magtape.brick;
   531.    begin
   532.       for i in 1 .. gaps_crossed loop
   533.          get_next_data_brick(the_deck, the_brick);
   534.          the_deck.is_abnormal := the_deck.is_abnormal or (the_brick.size mod 8 /= 0);
   535.       exit when the_deck.is_LBM_flagged;
   536.       end loop;
   537.    exception
   538.       when end_of_tape =>
   539.          the_deck.is_abnormal := True;
   540.    end skip_forwards;
   541.
   542.    procedure skip_backwards (the_deck     : in out magtape.deck;
   543.                              gaps_crossed : in KDF9.word) is
   544.       the_brick  : IOC.magtape.brick;
   545.    begin
   546.       for i in 1 .. gaps_crossed loop
   547.          get_prev_data_brick(the_deck, the_brick);
   548.          the_deck.is_abnormal := the_deck.is_abnormal or (the_brick.size mod 8 /= 0);
   549.       exit when the_deck.is_at_BOT;  -- I.e., the tape is fully rewound.
   550.       end loop;
   551.    end skip_backwards;
   552.
   553.    procedure erase_tape_gap (the_deck   : in out magtape.deck;
   554.                              the_length : in KDF9.word;
   555.                              gap_kind   : in tape_gap_kind := MGAP_gap) is
   556.       new_erased_length : constant KDF9.word := the_length * 8;
   557.       the_original : IOC.magtape.brick;
   558.    begin
   559.       if not the_deck.has_a_WP_ring then
   560.          trap_invalid_instruction("attempt to erase a read-only tape");
   561.       end if;
   562.       the_deck.is_LBM_flagged := False;
   563.       if gap_kind = MGAP_gap and
   564.             the_deck.brick_number < KDF9.word(Size(the_deck.tape.reel)) then
   565.          -- We are gapping; a wiped area must be under the write head.
   566.          get_tape_brick(the_deck, the_original);
   567.          if the_original.kind /= MT_erased_brick           or else
   568.                new_erased_length > the_original.erased_length then
   569.             trap_invalid_instruction("MGAPQq would overwrite data on " & the_deck.device_name);
   570.          end if;
   571.       end if;
   572.       declare
   573.          the_brick : constant IOC.magtape.brick
   574.                    := (size => 0, kind => MT_erased_brick, erased_length => new_erased_length);
   575.       begin
   576.          the_deck.brick_number := the_deck.brick_number + 1;
   577.          write(the_deck.tape, the_deck.brick_number, the_brick);
   578.       end;
   579.       update_statistics(the_deck, 1, new_erased_length, bytes_moved => 0);
   580.    exception
   581.       when IOC.magtape.end_of_tape =>
   582.          the_deck.is_abnormal := True;
   583.          raise;
   584.    end erase_tape_gap;
   585.
   586.    -- MRFQq
   587.    overriding
   588.    procedure PIA (the_deck    : in out magtape.deck;
   589.                   Q_operand   : in KDF9.Q_register;
   590.                   set_offline : in Boolean) is
   591.    begin
   592.       start_timed_transfer(the_deck, Q_operand, set_offline, 0);
   593.       read_block(the_deck, Q_operand, reading_to_EM => False);
   594.       set_lockouts(Q_operand);
   595.    end PIA;
   596.
   597.    -- MFREQq
   598.    overriding
   599.    procedure PIB (the_deck    : in out magtape.deck;
   600.                   Q_operand   : in KDF9.Q_register;
   601.                   set_offline : in Boolean) is
   602.    begin
   603.       start_timed_transfer(the_deck, Q_operand, set_offline, 0);
   604.       read_block(the_deck, Q_operand, reading_to_EM => True);
   605.       set_lockouts(Q_operand);
   606.    end;
   607.
   608.    -- as PIA
   609.    overriding
   610.    procedure PIC (the_deck    : in out magtape.deck;
   611.                   Q_operand   : in KDF9.Q_register;
   612.                   set_offline : in Boolean) is
   613.    begin
   614.       the_deck.PIA(Q_operand, set_offline);
   615.    end PIC;
   616.
   617.    -- as PIB
   618.    overriding
   619.    procedure PID (the_deck    : in out magtape.deck;
   620.                   Q_operand   : in KDF9.Q_register;
   621.                   set_offline : in Boolean) is
   622.    begin
   623.       the_deck.PIB(Q_operand, set_offline);
   624.    end PID;
   625.
   626.    -- MBRQq
   627.    overriding
   628.    procedure PIE (the_deck    : in out magtape.deck;
   629.                   Q_operand   : in KDF9.Q_register;
   630.                   set_offline : in Boolean) is
   631.    begin
   632.       if the_deck.is_at_BOT then
   633.          trap_invalid_instruction("attempt to read backwards at BOT");
   634.       end if;
   635.       start_timed_transfer(the_deck, Q_operand, set_offline, 0);
   636.       read_block_backwards(the_deck, Q_operand, reading_to_EM => False);
   637.       set_lockouts(Q_operand);
   638.    end PIE;
   639.
   640.    -- MBREQq
   641.    overriding
   642.    procedure PIF (the_deck    : in out magtape.deck;
   643.                   Q_operand   : in KDF9.Q_register;
   644.                   set_offline : in Boolean) is
   645.    begin
   646.       if the_deck.is_at_BOT then
   647.          trap_invalid_instruction("attempt to read backwards to End_Message at BOT");
   648.       end if;
   649.       start_timed_transfer(the_deck, Q_operand, set_offline, 0);
   650.       read_block_backwards(the_deck, Q_operand, reading_to_EM => True);
   651.       set_lockouts(Q_operand);
   652.    end PIF;
   653.
   654.    -- as PIE
   655.    overriding
   656.    procedure PIG (the_deck    : in out magtape.deck;
   657.                   Q_operand   : in KDF9.Q_register;
   658.                   set_offline : in Boolean) is
   659.    begin
   660.       the_deck.PIE(Q_operand, set_offline);
   661.    end PIG;
   662.
   663.    -- as PIF
   664.    overriding
   665.    procedure PIH (the_deck    : in out magtape.deck;
   666.                   Q_operand   : in KDF9.Q_register;
   667.                   set_offline : in Boolean) is
   668.    begin
   669.       the_deck.PIF(Q_operand, set_offline);
   670.    end PIH;
   671.
   672.    -- MFSKQq
   673.    overriding
   674.    procedure PMA (the_deck    : in out magtape.deck;
   675.                   Q_operand   : in KDF9.Q_register;
   676.                   set_offline : in Boolean) is
   677.    begin
   678.       start_timed_transfer(the_deck, Q_operand, set_offline, 0, is_DMAing => False);
   679.       if Q_operand.M = 0 then
   680.          skip_forwards(the_deck, 32768);  -- See Manual §22.1.9, p188, ¶1.
   681.       else
   682.          skip_forwards(the_deck, KDF9.word(Q_operand.M));
   683.       end if;
   684.    end PMA;
   685.
   686.    -- MBTQq
   687.    overriding
   688.    procedure PMB (the_deck    : in out magtape.deck;
   689.                   Q_operand   : in KDF9.Q_register;
   690.                   set_offline : in Boolean) is
   691.       pragma Unreferenced(set_offline);
   692.    begin
   693.       validate_device(the_deck, Q_operand);
   694.       validate_parity(the_deck);
   695.       the_T_bit := KDF9.word(Boolean'Pos(is_at_BOT(the_deck)));
   696.       take_note_of(Q_operand, the_deck.device_name, the_T_bit);
   697.    end PMB;
   698.
   699.    -- MLBQq
   700.    overriding
   701.    procedure PMC (the_deck    : in out magtape.deck;
   702.                   Q_operand   : in KDF9.Q_register;
   703.                   set_offline : in Boolean) is
   704.       pragma Unreferenced(set_offline);
   705.    begin
   706.       validate_device(the_deck, Q_operand);
   707.       validate_parity(the_deck);
   708.       the_T_bit := KDF9.word(Boolean'Pos(is_at_LBM(the_deck)));
   709.       take_note_of(Q_operand, the_deck.device_name, the_T_bit);
   710.    end PMC;
   711.
   712.    -- MRWDQq
   713.    overriding
   714.    procedure PMD (the_deck    : in out magtape.deck;
   715.                   Q_operand   : in KDF9.Q_register;
   716.                   set_offline : in Boolean) is
   717.    begin
   718.       the_deck.is_abnormal := False;  -- See Manual §22.1.9, p.189, ¶-2.
   719.       -- This is a STUB re timing: I don't know what the rewind speed was.
   720.       if the_deck.is_at_BOT then
   721.          -- No motion takes place; see Manual §22.1.9, p.190, ¶1.
   722.          take_note_of(Q_operand,
   723.                       the_deck.device_name,
   724.                       KDF9.word(Boolean'Pos(the_deck.is_at_BOT))
   725.                      );
   726.       else
   727.          the_deck.brick_number := the_deck.brick_number - 1;
   728.          start_timed_transfer(the_deck, Q_operand, set_offline, 0, is_DMAing => False);
   729.          skip_backwards(the_deck, the_deck.brick_number);
   730.       end if;
   731.       if not the_deck.is_at_BOT then
   732.          trap_invalid_instruction("not at BOT after rewinding " & the_deck.device_name);
   733.       end if;
   734.    end PMD;
   735.
   736.    -- MBSKQq
   737.    overriding
   738.    procedure PME (the_deck    : in out magtape.deck;
   739.                   Q_operand   : in KDF9.Q_register;
   740.                   set_offline : in Boolean) is
   741.    begin
   742.       if the_deck.is_at_BOT then
   743.          trap_invalid_instruction("attempt to skip backwards at BOT");
   744.       end if;
   745.       start_timed_transfer(the_deck, Q_operand, set_offline, 0, is_DMAing => False);
   746.       if Q_operand.M = 0 then
   747.          skip_backwards(the_deck, 32768);  -- See Manual §22.1.9, p188, ¶1.
   748.       else
   749.          skip_backwards(the_deck, KDF9.word(Q_operand.M));
   750.       end if;
   751.    end PME;
   752.
   753.    -- METQq
   754.    overriding
   755.    procedure PMF (the_deck    : in out magtape.deck;
   756.                   Q_operand   : in KDF9.Q_register;
   757.                   set_offline : in Boolean) is
   758.       pragma Unreferenced(set_offline);
   759.    begin
   760.       validate_device(the_deck, Q_operand);
   761.       validate_parity(the_deck);
   762.       the_T_bit := KDF9.word(Boolean'Pos(is_at_ETW(the_deck)));
   763.       take_note_of(Q_operand, the_deck.device_name, the_T_bit);
   764.    end PMF;
   765.
   766.    -- MWQq
   767.    overriding
   768.    procedure POA (the_deck    : in out magtape.deck;
   769.                   Q_operand   : in KDF9.Q_register;
   770.                   set_offline : in Boolean) is
   771.    begin
   772.       start_timed_transfer(the_deck, Q_operand, set_offline, 0);
   773.       write(the_deck, Q_operand);
   774.       set_lockouts(Q_operand);
   775.    end POA;
   776.
   777.    -- MWEQq
   778.    overriding
   779.    procedure POB (the_deck    : in out magtape.deck;
   780.                   Q_operand   : in KDF9.Q_register;
   781.                   set_offline : in Boolean) is
   782.    begin
   783.       start_timed_transfer(the_deck, Q_operand, set_offline, 0);
   784.       write_to_EM(the_deck, Q_operand);
   785.       set_lockouts(Q_operand);
   786.    end POB;
   787.
   788.    -- MLWQq
   789.    overriding
   790.    procedure POC (the_deck    : in out magtape.deck;
   791.                   Q_operand   : in KDF9.Q_register;
   792.                   set_offline : in Boolean) is
   793.    begin
   794.       start_timed_transfer(the_deck, Q_operand, set_offline, 0);
   795.       write(the_deck, Q_operand, is_LBM_flagged => True);
   796.       set_lockouts(Q_operand);
   797.    end POC;
   798.
   799.    -- MLWEQq
   800.    overriding
   801.    procedure POD (the_deck    : in out magtape.deck;
   802.                   Q_operand   : in KDF9.Q_register;
   803.                   set_offline : in Boolean) is
   804.    begin
   805.       start_timed_transfer(the_deck, Q_operand, set_offline, 0);
   806.       write_to_EM(the_deck, Q_operand, is_LBM_flagged => True);
   807.       set_lockouts(Q_operand);
   808.    end POD;
   809.
   810.    -- MGAPQq
   811.    overriding
   812.    procedure POE (the_deck    : in out magtape.deck;
   813.                   Q_operand   : in KDF9.Q_register;
   814.                   set_offline : in Boolean) is
   815.    begin
   816.       start_timed_transfer(the_deck, Q_operand, set_offline, 0, is_DMAing => False);
   817.       require_positive_count(Q_operand.M);
   818.       erase_tape_gap(the_deck, KDF9.word(Q_operand.M), gap_kind => MGAP_gap);
   819.    end POE;
   820.
   821.    -- MWIPEQq
   822.    overriding
   823.    procedure POF (the_deck    : in out magtape.deck;
   824.                   Q_operand   : in KDF9.Q_register;
   825.                   set_offline : in Boolean) is
   826.    begin
   827.       start_timed_transfer(the_deck, Q_operand, set_offline, 0, is_DMAing => False);
   828.       require_positive_count(Q_operand.M);
   829.       erase_tape_gap(the_deck, KDF9.word(Q_operand.M), gap_kind => MWIPE_gap);
   830.    end POF;
   831.
   832. end IOC.magtape;

Compiling: ../Source\ioc-magtape.ads
Source file time stamp: 2015-06-18 00:56:24
Compiled at: 2015-10-28 18:14:28

     1. -- ioc-magtape.ads
     2. --
     3. -- Emulation of magnetic tape buffer commonalities.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. private with Ada.Direct_IO;
    20. --
    21. private with KDF9.store;
    22.
    23. package IOC.magtape is
    24.
    25.    pragma Unsuppress(All_Checks);
    26.
    27.    type deck is new IOC.device with private;
    28.
    29.    -- MRFQq
    30.    overriding
    31.    procedure PIA (the_deck    : in out magtape.deck;
    32.                   Q_operand   : in KDF9.Q_register;
    33.                   set_offline : in Boolean);
    34.    -- MFREQq
    35.    overriding
    36.    procedure PIB (the_deck    : in out magtape.deck;
    37.                   Q_operand   : in KDF9.Q_register;
    38.                   set_offline : in Boolean);
    39.    -- as PIA
    40.    overriding
    41.    procedure PIC (the_deck    : in out magtape.deck;
    42.                   Q_operand   : in KDF9.Q_register;
    43.                   set_offline : in Boolean);
    44.    -- as PID
    45.    overriding
    46.    procedure PID (the_deck    : in out magtape.deck;
    47.                   Q_operand   : in KDF9.Q_register;
    48.                   set_offline : in Boolean);
    49.    -- MBRQq
    50.    overriding
    51.    procedure PIE (the_deck    : in out magtape.deck;
    52.                   Q_operand   : in KDF9.Q_register;
    53.                   set_offline : in Boolean);
    54.    -- MBREQq
    55.    overriding
    56.    procedure PIF (the_deck    : in out magtape.deck;
    57.                   Q_operand   : in KDF9.Q_register;
    58.                   set_offline : in Boolean);
    59.    -- as PIE
    60.    overriding
    61.    procedure PIG (the_deck    : in out magtape.deck;
    62.                   Q_operand   : in KDF9.Q_register;
    63.                   set_offline : in Boolean);
    64.    -- as PIF
    65.    overriding
    66.    procedure PIH (the_deck    : in out magtape.deck;
    67.                   Q_operand   : in KDF9.Q_register;
    68.                   set_offline : in Boolean);
    69.
    70.    -- MFSKQq
    71.    overriding
    72.    procedure PMA (the_deck    : in out magtape.deck;
    73.                   Q_operand   : in KDF9.Q_register;
    74.                   set_offline : in Boolean);
    75.    -- MBTQq
    76.    overriding
    77.    procedure PMB (the_deck    : in out magtape.deck;
    78.                   Q_operand   : in KDF9.Q_register;
    79.                   set_offline : in Boolean);
    80.    -- MLBQq
    81.    overriding
    82.    procedure PMC (the_deck    : in out magtape.deck;
    83.                   Q_operand   : in KDF9.Q_register;
    84.                   set_offline : in Boolean);
    85.    -- MRWDQq
    86.    overriding
    87.    procedure PMD (the_deck    : in out magtape.deck;
    88.                   Q_operand   : in KDF9.Q_register;
    89.                   set_offline : in Boolean);
    90.    -- MBSKQq
    91.    overriding
    92.    procedure PME (the_deck    : in out magtape.deck;
    93.                   Q_operand   : in KDF9.Q_register;
    94.                   set_offline : in Boolean);
    95.    -- METQq
    96.    overriding
    97.    procedure PMF (the_deck    : in out magtape.deck;
    98.                   Q_operand   : in KDF9.Q_register;
    99.                   set_offline : in Boolean);
   100.
   101.    -- MWQq
   102.    overriding
   103.    procedure POA (the_deck    : in out magtape.deck;
   104.                   Q_operand   : in KDF9.Q_register;
   105.                   set_offline : in Boolean);
   106.    -- MWEQq
   107.    overriding
   108.    procedure POB (the_deck    : in out magtape.deck;
   109.                   Q_operand   : in KDF9.Q_register;
   110.                   set_offline : in Boolean);
   111.    -- MLWQq
   112.    overriding
   113.    procedure POC (the_deck    : in out magtape.deck;
   114.                   Q_operand   : in KDF9.Q_register;
   115.                   set_offline : in Boolean);
   116.    -- MLWEQq
   117.    overriding
   118.    procedure POD (the_deck    : in out magtape.deck;
   119.                   Q_operand   : in KDF9.Q_register;
   120.                   set_offline : in Boolean);
   121.    -- MGAPQq
   122.    overriding
   123.    procedure POE (the_deck    : in out magtape.deck;
   124.                   Q_operand   : in KDF9.Q_register;
   125.                   set_offline : in Boolean);
   126.    -- MWIPEQq
   127.    overriding
   128.    procedure POF (the_deck    : in out magtape.deck;
   129.                   Q_operand   : in KDF9.Q_register;
   130.                   set_offline : in Boolean);
   131.
   132.    -- The following support the emulation of OUTs 4 and 10.
   133.    type short_label   is new String(1 .. 8);
   134.    type long_label    is new String(1 .. 16);
   135.
   136.    procedure find_tape_labelled (the_label  : in magtape.short_label;
   137.                                  its_number : out KDF9.buffer_number;
   138.                                  its_serial : out KDF9.word);
   139.
   140.    procedure find_tape_labelled (the_label  : in magtape.long_label;
   141.                                  its_number : out KDF9.buffer_number;
   142.                                  its_serial : out KDF9.word);
   143.
   144. private
   145.
   146.    use KDF9.store; pragma Warnings(Off, KDF9.store);
   147.
   148.    -- For now, a data block or erased gap is confined to a single brick.
   149.    -- The next version will allow for as many bricks as necessary.
   150.
   151.    type MT_brick_kind is (MT_mark_brick, MT_erased_brick, MT_data_brick);
   152.
   153.    type MT_mark_kind is (even_parity_tape_mark, odd_parity_tape_mark);
   154.
   155.    max_brick_size : constant := 512 * 8;
   156.
   157.    subtype brick_size_range is Natural range 0 .. max_brick_size;
   158.
   159.    type brick (kind : MT_brick_kind    := MT_data_brick;
   160.                size : brick_size_range := 0) is
   161.       record
   162.          case kind is
   163.             when MT_mark_brick =>
   164.                tape_mark : MT_mark_kind;
   165.             when MT_erased_brick =>
   166.                erased_length : KDF9.word;
   167.             when MT_data_brick =>
   168.                is_LBM_flagged : Boolean;
   169.                data : String(1 .. size);
   170.          end case;
   171.       end record;
   172.
   173.    IBM_even_mark : constant brick
   174.                  := (size => 0, kind => MT_mark_brick, tape_mark => even_parity_tape_mark);
   175.    IBM_odd_mark  : constant brick
   176.                  := (size => 0, kind => MT_mark_brick, tape_mark => odd_parity_tape_mark);
   177.
   178.    package MT_brick_IO is new Ada.Direct_IO(IOC.magtape.brick);
   179.
   180.    type file is tagged limited
   181.       record
   182.          reel : MT_brick_IO.File_Type;
   183.       end record;
   184.
   185.    function is_open (tape : in magtape.file)
   186.    return Boolean;
   187.
   188.    procedure open_RW (tape : in out magtape.file;
   189.                       name : in String);
   190.
   191.    procedure open_RO (tape : in out magtape.file;
   192.                       name : in String);
   193.
   194.    procedure close (tape : in out magtape.file);
   195.
   196.    procedure write (tape  : in magtape.file;
   197.                     index : in KDF9.word;
   198.                     stuff : in IOC.magtape.brick);
   199.
   200.    procedure read (tape  : in magtape.file;
   201.                    index : in KDF9.word;
   202.                    stuff : out IOC.magtape.brick);
   203.
   204.    end_of_tape : exception;
   205.
   206.    type deck is new IOC.device with
   207.       record
   208.          tape : magtape.file;
   209.          has_a_WP_ring  : Boolean := True;
   210.          is_LBM_flagged : Boolean := False;
   211.          bytes_moved,
   212.          gaps_crossed,
   213.          brick_number,
   214.          erased_length : KDF9.word := 0;
   215.          elapsed_time_total : KDF9.microseconds := 0;
   216.       end record;
   217.
   218.    overriding
   219.    procedure Initialize (the_deck : in out magtape.deck);
   220.
   221.    overriding
   222.    procedure Finalize (the_deck : in out magtape.deck);
   223.
   224.    procedure open (the_deck : in out magtape.deck;
   225.                    the_mode : in POSIX.access_mode)
   226.    is null;
   227.
   228.    procedure open (the_deck : in out magtape.deck);
   229.
   230.    overriding
   231.    function is_open (the_deck : magtape.deck)
   232.    return Boolean;
   233.
   234.    overriding
   235.    function usage (the_deck : magtape.deck)
   236.    return KDF9.word;
   237.
   238.    overriding
   239.    procedure close (the_deck : in out magtape.deck);
   240.
   241.    overriding
   242.    function IO_elapsed_time_total (the_deck : magtape.deck)
   243.    return KDF9.microseconds;
   244.
   245.    -- Is the tape at the Beginning Of Tape window?
   246.    not overriding
   247.    function is_at_BOT (the_deck : magtape.deck)
   248.    return Boolean;
   249.
   250.    -- Is the tape at the End of Tape Warning?
   251.    not overriding
   252.    function is_at_ETW (the_deck : magtape.deck)
   253.    return Boolean;
   254.
   255.    -- Does the last block read have a Last Block Marker?
   256.    not overriding
   257.    function is_at_LBM (the_deck : magtape.deck)
   258.    return Boolean;
   259.
   260.    overriding
   261.    procedure flush(the_deck : in out magtape.deck) is null;
   262.
   263.    procedure read_block (the_deck      : in out magtape.deck;
   264.                          Q_operand     : in KDF9.Q_register;
   265.                          reading_to_EM : in Boolean := False);
   266.
   267.    procedure read_block_backwards  (the_deck      : in out magtape.deck;
   268.                                     Q_operand     : in KDF9.Q_register;
   269.                                     reading_to_EM : in Boolean := False);
   270.
   271.    procedure write  (the_deck       : in out magtape.deck;
   272.                      Q_operand      : in KDF9.Q_register;
   273.                      is_LBM_flagged : in Boolean := False);
   274.
   275.    procedure write_to_EM (the_deck       : in out magtape.deck;
   276.                           Q_operand      : in KDF9.Q_register;
   277.                           is_LBM_flagged : in Boolean := False);
   278.
   279.    procedure skip_forwards (the_deck     : in out magtape.deck;
   280.                             gaps_crossed : in KDF9.word);
   281.
   282.    procedure skip_backwards (the_deck     : in out magtape.deck;
   283.                              gaps_crossed : in KDF9.word);
   284.
   285.    type tape_gap_kind is (MGAP_gap, MWIPE_gap);
   286.
   287.    procedure erase_tape_gap (the_deck   : in out magtape.deck;
   288.                              the_length : in KDF9.word;
   289.                              gap_kind   : in tape_gap_kind := MGAP_gap);
   290.
   291. end IOC.magtape;

 832 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-magtape-mt.ads
Source file time stamp: 2015-06-18 00:56:28
Compiled at: 2015-10-28 18:14:33

     1. -- ioc-magtape-mt.adb
     2. --
     3. -- Emulation of a KDF9-native magnetic tape buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with IOC.magtape; pragma Elaborate_All(IOC.magtape);
    20.
    21.
    22. package IOC.magtape.MT is
    23.
    24.    pragma Unsuppress(All_Checks);
    25.
    26.
    27.    type deck is new magtape.deck with private;
    28.
    29. private
    30.
    31.    type deck is new magtape.deck with null record;
    32.
    33.    MT_quantum : constant := 1E6 / 40E3;  -- 40_000 characters per second.
    34.
    35.    MT0 : aliased deck (number  => MT0_number+0,
    36.                        kind    => MT_kind,
    37.                        unit    => 0,
    38.                        quantum => MT_quantum,
    39.                        is_slow => False);
    40.
    41.    MT1 : aliased deck (number  => MT0_number+1,
    42.                        kind    => MT_kind,
    43.                        unit    => 1,
    44.                        quantum => MT_quantum,
    45.                        is_slow => False);
    46.
    47.    MT2 : aliased deck (number  => MT0_number+2,
    48.                        kind    => MT_kind,
    49.                        unit    => 2,
    50.                        quantum => MT_quantum,
    51.                        is_slow => False);
    52.
    53.    MT3 : aliased deck (number  => MT0_number+3,
    54.                        kind    => MT_kind,
    55.                        unit    => 3,
    56.                        quantum => MT_quantum,
    57.                        is_slow => False);
    58.
    59.    MT4 : aliased deck (number  => MT0_number+4,
    60.                        kind    => MT_kind,
    61.                        unit    => 4,
    62.                        quantum => MT_quantum,
    63.                        is_slow => False);
    64.
    65.    MT5 : aliased deck (number  => MT0_number+5,
    66.                        kind    => MT_kind,
    67.                        unit    => 5,
    68.                        quantum => MT_quantum,
    69.                        is_slow => False);
    70.
    71.    MT6 : aliased deck (number  => MT0_number+6,
    72.                        kind    => MT_kind,
    73.                        unit    => 6,
    74.                        quantum => MT_quantum,
    75.                        is_slow => False);
    76.
    77. end IOC.magtape.MT;

 77 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-magtape-st.adb
Source file time stamp: 2015-06-18 00:56:26
Compiled at: 2015-10-28 18:14:34

     1. -- ioc-magtape-st.adb
     2. --
     3. -- Emulation of a 7-track IBM-compatible magnetic tape buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package body IOC.magtape.ST is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    overriding
    24.    procedure PMK (the_IBM     : in out ST.deck;
    25.                   Q_operand   : in KDF9.Q_register;
    26.                   set_offline : in Boolean) is
    27.    begin
    28.       the_IBM.PMA(Q_operand, set_offline);
    29.    end PMK;
    30.
    31.    overriding
    32.    procedure PML (the_IBM     : in out ST.deck;
    33.                   Q_operand   : in KDF9.Q_register;
    34.                   set_offline : in Boolean) is
    35.    begin
    36.       the_IBM.PME(Q_operand, set_offline);
    37.    end PML;
    38.
    39. end IOC.magtape.ST;

Compiling: ../Source\ioc-magtape-st.ads
Source file time stamp: 2015-06-18 00:56:26
Compiled at: 2015-10-28 18:14:34

     1. -- ioc-magtape-st.adb
     2. --
     3. -- Emulation of a 7-track IBM-compatible magnetic tape buffer.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package IOC.magtape.ST is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    type deck is new IOC.magtape.deck with private;
    24.
    25.    -- MFSKQq, as PMA, but even parity
    26.    overriding
    27.    procedure PMK (the_IBM     : in out ST.deck;
    28.                   Q_operand   : in KDF9.Q_register;
    29.                   set_offline : in Boolean);
    30.    -- MBSKQq, as PME, but even parity
    31.    overriding
    32.    procedure PML (the_IBM     : in out ST.deck;
    33.                   Q_operand   : in KDF9.Q_register;
    34.                   set_offline : in Boolean);
    35.
    36. private
    37.
    38.    type deck is new IOC.magtape.deck with null record;
    39.
    40. end IOC.magtape.ST;

 39 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-two_shift-fw.adb
Source file time stamp: 2015-06-18 00:56:24
Compiled at: 2015-10-28 18:14:34

     1. -- ioc-shift_devices-fw.adb
     2. --
     3. -- Emulation of a FlexoWriter buffer: monitor typewriter functionality.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Exceptions;
    20. with Ada.Text_IO;
    21. --
    22. with exceptions;
    23. with HCI; pragma Elaborate_All(HCI);
    24. with IO; pragma Elaborate_All(IO);
    25. with IOC; pragma Elaborate_All(IOC);
    26. with KDF9.store;
    27. with POSIX;
    28. with OS_specifics;
    29. with settings;
    30.
    31. pragma Unreferenced(IO);
    32. pragma Unreferenced(POSIX);
    33.
    34. use  Ada.Text_IO;
    35. --
    36. use  HCI;
    37. use  KDF9.store;
    38. use  OS_specifics;
    39. use  settings;
    40.
    41. package body IOC.two_shift.FW is
    42.
    43.    pragma Unsuppress(All_Checks);
    44.
    45.    use Latin_1;
    46.
    47.    function a_LF_was_just_read (the_FW : FW.device)
    48.    return Boolean is
    49.    begin
    50.       return the_FW.mode = the_flexowriter_is_reading and a_LF_was_just_read(the_FW.stream);
    51.    end a_LF_was_just_read;
    52.
    53.    overriding
    54.    procedure Finalize (the_FW : in out FW.device) is
    55.    begin
    56.       close(the_FW, "typed", the_FW.output.bytes_moved+the_FW.stream.bytes_moved, "character(s)");
    57.    end Finalize;
    58.
    59.    max_text_length : constant Positive := 120;
    60.
    61.    type interaction is
    62.       record
    63.          text           : String(1 .. max_text_length);
    64.          prompt_length,
    65.          total_length   : Positive range 1 .. max_text_length;
    66.       end record;
    67.
    68.     -- A '®' denotes LF, and a '©' denotes FF in an interaction text input.
    69.    LF_surrogate     : constant Character := '®';
    70.    FF_surrogate     : constant Character := '©';
    71.
    72.    max_interactions : constant Positive := 10;
    73.
    74.    interactions : array (1 .. max_interactions) of IOC.two_shift.FW.interaction;
    75.
    76.    next_interaction : Positive := 1;
    77.    last_interaction : Natural  := 0;
    78.
    79.    overriding
    80.    procedure Initialize (the_FW : in out FW.device) is
    81.       interaction_file : Ada.Text_IO.File_Type;
    82.    begin
    83.       ensure_ui_is_open;
    84.       the_FW.mode := the_flexowriter_is_writing;
    85.       the_FW.device_name := logical_device_name_of(the_FW);
    86.       if the_FW.device_name = "FW0" then
    87.          -- Attempt to open a command file for the console the_FW.
    88.          begin
    89.             Open(interaction_file, In_File, "FW0");
    90.          response_list_loop:
    91.             while not End_of_file(interaction_file) loop
    92.                if last_interaction = max_interactions then
    93.                   log_line("The file FW0 contains too many interactions!");
    94.                   raise Ada.Text_IO.Data_Error;
    95.                end if;
    96.                last_interaction := last_interaction + 1;
    97.                declare
    98.                   interaction       : String  := Get_Line(interaction_file);
    99.                   the_prompt_length : Natural := 0;
   100.                begin
   101.                   if interaction'Length > max_text_length then
   102.                      log_line("The file FW0 contains an overlong string: '"
   103.                             & interaction
   104.                             & "'!");
   105.                      raise Ada.Text_IO.Data_Error;
   106.                   end if;
   107.
   108.                   exit response_list_loop when interaction'Length = 0;
   109.
   110.                   for p in 1 .. interaction'Length loop
   111.                      if interaction(p) = ';' then
   112.                         the_prompt_length := p;
   113.                      elsif interaction(p) = LF_surrogate then
   114.                         -- Convert '®' to LF to allow for multi-line prompts.
   115.                         interaction(p) := LF;
   116.                      elsif interaction(p) = FF_surrogate then
   117.                         -- Convert '©' to FF to allow for multi-line prompts.
   118.                         interaction(p) := FF;
   119.                      end if;
   120.                   end loop;
   121.
   122.                   if the_prompt_length = 0 then
   123.                      log_line("The file FW0 contains a string: '"
   124.                             & interaction
   125.                             & "' without a semicolon!");
   126.                      raise Ada.Text_IO.Data_Error;
   127.                   end if;
   128.
   129.                   interactions(last_interaction).text(1 .. interaction'Length) := interaction;
   130.                   interactions(last_interaction).prompt_length := the_prompt_length;
   131.                   interactions(last_interaction).total_length := interaction'Length;
   132.                end;
   133.             end loop response_list_loop;
   134.          exception
   135.             when Name_Error =>
   136.                null;
   137.             when Use_Error =>
   138.                log_line("The file 'FW0' exists, but cannot be read!");
   139.             when error : others =>
   140.                log_line("Failure in ee9: "
   141.                       & Ada.Exceptions.Exception_Information(error)
   142.                       & " was raised for 'FW0' in 'Initialize'!");
   143.          end;
   144.       end if;
   145.       open(the_FW.stream, the_FW.device_name, read_mode, ui_in_fd);
   146.       open(the_FW.output, the_FW.device_name, write_mode, ui_out_fd);
   147.       IOC.device(the_FW).Initialize;
   148.       the_FW.current_case := KDF9.Case_Normal;
   149.    end Initialize;
   150.
   151.    -- If authentic timing, a delay of length the_pause is inserted between characters output
   152.    --    to a Flexowriter, with the aim of approximating the actual speed of its typing.
   153.    the_pause  : KDF9.microseconds := 0;
   154.
   155.    procedure set_the_duration_of_the_pause (the_FW : in FW.device) is
   156.    begin
   157.       if authentic_timing_is_wanted then
   158.          the_pause := the_FW.quantum;
   159.       else
   160.          the_pause := 0;
   161.       end if;
   162.    end set_the_duration_of_the_pause;
   163.
   164.    call_for_manual_input    : constant String (1..2) := (others => BEL);
   165.    noninteractive_complaint : constant String := "ee9 cannot read from the Flexowriter";
   166.
   167.    procedure inject_a_response (the_FW     : in out FW.device;
   168.                                 the_prompt : in String;
   169.                                 the_size   : in out KDF9.word) is
   170.    begin
   171.       set_the_duration_of_the_pause(the_FW);
   172.       for t in next_interaction .. last_interaction loop
   173.          declare
   174.             a : interaction renames interactions(t);
   175.          begin
   176.             if a.prompt_length = a.total_length then
   177.                -- A null response, so terminate the program.
   178.                raise exceptions.quit_request with "at the prompt: '" & the_prompt & "'";
   179.             end if;
   180.             next_interaction := next_interaction + 1;
   181.             if a.text(1..a.prompt_length-1) = the_prompt and then
   182.                   a.text(a.prompt_length-0) = ';'            then
   183.                inject(a.text(a.prompt_length+1..a.total_length) & LF, the_FW.stream);
   184.                the_size := the_size + KDF9.word(a.total_length-a.prompt_length);
   185.                put_chars(a.text(a.prompt_length+1..a.total_length) & LF, the_FW.output);
   186.                -- Human operators type much more slowly than KDF9 buffers!
   187.                flush(the_FW.output, the_pause*5);
   188.                the_FW.mode := the_flexowriter_is_reading;
   189.                return;
   190.             end if;
   191.          end;
   192.       end loop;
   193.       -- No canned response is available, so control reverts to the terminal.
   194.       -- Output an audible signal to notify the operator.
   195.       if noninteractive_usage_is_enabled then
   196.          raise input_is_impossible with noninteractive_complaint;
   197.       end if;
   198.       put_bytes(call_for_manual_input, the_FW.output);
   199.       flush(the_FW.output, the_pause);
   200.       the_FW.mode := the_flexowriter_is_reading;
   201.    end inject_a_response;
   202.
   203.    -- TRQq
   204.    overriding
   205.    procedure PIA (the_FW      : in out FW.device;
   206.                   Q_operand   : in KDF9.Q_register;
   207.                   set_offline : in Boolean) is
   208.    begin
   209.       if noninteractive_usage_is_enabled then
   210.          raise input_is_impossible with noninteractive_complaint;
   211.       end if;
   212.       put_bytes(call_for_manual_input, the_FW.output);
   213.       flush(the_FW.output);
   214.       the_FW.mode := the_flexowriter_is_reading;
   215.       initialize_byte_mode_transfer(the_FW, Q_operand, set_offline);
   216.       read(the_FW, Q_operand);
   217.       set_lockouts(Q_operand);
   218.       reset(the_FW.stream);
   219.    end PIA;
   220.
   221.    -- TREQq
   222.    overriding
   223.    procedure PIB (the_FW      : in out FW.device;
   224.                   Q_operand   : in KDF9.Q_register;
   225.                   set_offline : in Boolean) is
   226.    begin
   227.       if noninteractive_usage_is_enabled then
   228.          raise input_is_impossible with noninteractive_complaint;
   229.       end if;
   230.       put_bytes(call_for_manual_input, the_FW.output);
   231.       flush(the_FW.output);
   232.       the_FW.mode := the_flexowriter_is_reading;
   233.       initialize_byte_mode_transfer(the_FW, Q_operand, set_offline);
   234.       read_to_EM(the_FW, Q_operand);
   235.       set_lockouts(Q_operand);
   236.       reset(the_FW.stream);
   237.    end PIB;
   238.
   239.    overriding
   240.    procedure PIC (the_FW      : in out FW.device;
   241.                   Q_operand   : in KDF9.Q_register;
   242.                   set_offline : in Boolean) is
   243.    begin
   244.       if noninteractive_usage_is_enabled then
   245.          raise input_is_impossible with noninteractive_complaint;
   246.       end if;
   247.       put_bytes(call_for_manual_input, the_FW.output);
   248.       flush(the_FW.output);
   249.       the_FW.mode := the_flexowriter_is_reading;
   250.       initialize_byte_mode_transfer(the_FW, Q_operand, set_offline);
   251.       words_read(the_FW, Q_operand);
   252.       set_lockouts(Q_operand);
   253.       reset(the_FW.stream);
   254.    end PIC;
   255.
   256.    overriding
   257.    procedure PID (the_FW      : in out FW.device;
   258.                   Q_operand   : in KDF9.Q_register;
   259.                   set_offline : in Boolean) is
   260.    begin
   261.       if noninteractive_usage_is_enabled then
   262.          raise input_is_impossible with noninteractive_complaint;
   263.       end if;
   264.       put_bytes(call_for_manual_input, the_FW.output);
   265.       flush(the_FW.output);
   266.       the_FW.mode := the_flexowriter_is_reading;
   267.       initialize_byte_mode_transfer(the_FW, Q_operand, set_offline);
   268.       words_read_to_EM(the_FW, Q_operand);
   269.       set_lockouts(Q_operand);
   270.       reset(the_FW.stream);
   271.    end PID;
   272.
   273.    overriding
   274.    procedure PIE (the_FW      : in out FW.device;
   275.                   Q_operand   : in KDF9.Q_register;
   276.                   set_offline : in Boolean) is
   277.    begin
   278.       PIA(the_FW, Q_operand, set_offline);
   279.    end PIE;
   280.
   281.    overriding
   282.    procedure PIF (the_FW      : in out FW.device;
   283.                   Q_operand   : in KDF9.Q_register;
   284.                   set_offline : in Boolean) is
   285.    begin
   286.       PIB(the_FW, Q_operand, set_offline);
   287.    end PIF;
   288.
   289.    overriding
   290.    procedure PIG (the_FW      : in out FW.device;
   291.                   Q_operand   : in KDF9.Q_register;
   292.                   set_offline : in Boolean) is
   293.    begin
   294.       PIC(the_FW, Q_operand, set_offline);
   295.    end PIG;
   296.
   297.    overriding
   298.    procedure PIH (the_FW      : in out FW.device;
   299.                   Q_operand   : in KDF9.Q_register;
   300.                   set_offline : in Boolean) is
   301.    begin
   302.       PID(the_FW, Q_operand, set_offline);
   303.    end PIH;
   304.
   305.    -- neat strips off any enclosing non-graphic characters from s.
   306.    function neat (s : String)
   307.    return String is
   308.       l : Positive := 1;
   309.       r : Natural  := 0;
   310.    begin
   311.       for i in s'Range loop
   312.          l := i;
   313.       exit when s(i) > ' ' and s(i) /= DEL;
   314.       end loop;
   315.       for i in reverse s'Range loop
   316.          r := i;
   317.       exit when s(i) > ' ' and s(i) /= DEL;
   318.       end loop;
   319.       return s(l..r);  -- s(1..0) yields a null string when s is a null string.
   320.    end neat;
   321.
   322.    overriding
   323.    procedure do_output_housekeeping (the_FW   : in out FW.device;
   324.                                     written,
   325.                                     fetched  : in KDF9.word) is
   326.    begin
   327.       flush(the_FW.stream);
   328.       add_in_the_IO_CPU_time(the_FW, fetched);
   329.       correct_transfer_time(the_FW, written);
   330.       the_FW.byte_count := the_FW.byte_count + fetched;
   331.    end do_output_housekeeping;
   332.
   333.    procedure put_symbols (the_FW         : in out FW.device;
   334.                           Q_operand      : in KDF9.Q_register;
   335.                           transfer_to_EM : in Boolean) is
   336.       start_address : constant KDF9.address := Q_operand.I;
   337.       end_address   : constant KDF9.address := Q_operand.M;
   338.       fill   : KDF9.word := 0;
   339.       size   : KDF9.word := 0;
   340.       symbol : KDF9.symbol;
   341.       char   : Character;
   342.    begin
   343.       validate_range_access(start_address, end_address);
   344.       set_the_duration_of_the_pause(the_FW);
   345.       -- Ensure that a prompt occupies the buffer alone.
   346.       flush(the_FW.output, the_pause);
   347.       the_FW.mode := the_flexowriter_is_writing;
   348.       set_text_colour_to_red(the_FW.output);
   349.    word_loop:
   350.       for w in start_address .. end_address loop
   351.          for c in KDF9.symbol_number'Range loop
   352.             case the_FW.mode is
   353.                when the_flexowriter_is_writing =>
   354.                   symbol := fetch_symbol(w, c);
   355.                   size := size + 1;
   356.                   if symbol = KDF9.Word_Filler then
   357.                      fill := fill + 1;
   358.                   elsif symbol = KDF9.Case_Shift then
   359.                      the_FW.current_case := KDF9.Case_Shift;
   360.                   elsif  symbol = KDF9.Case_Normal then
   361.                      the_FW.current_case := KDF9.Case_Normal;
   362.                   else
   363.                      if the_FW.current_case = KDF9.Case_Normal then
   364.                         char := TP_CN(symbol);
   365.                      else
   366.                         char := TP_CS(symbol);
   367.                      end if;
   368.                      if char = ';' then
   369.                         declare
   370.                            the_prompt : constant String := neat(contents(the_FW.output));
   371.                         begin
   372.                            flush(the_FW.output, the_pause);
   373.                            set_text_colour_to_black(the_FW.output);
   374.                            put_byte(';', the_FW.output);
   375.                            flush(the_FW.output, the_pause);
   376.                            inject_a_response(the_FW, the_prompt, size);
   377.                            the_FW.mode := the_flexowriter_is_reading;
   378.                         end;
   379.                      else
   380.                         put_char(char, the_FW.output);
   381.                      end if;
   382.                      exit word_loop when transfer_to_EM and symbol = KDF9.End_Message;
   383.                   end if;
   384.                when the_flexowriter_is_reading =>
   385.                   get_char(char, the_FW.stream);
   386.                   if case_of(char) /= both and case_of(char) /= the_FW.current_case then
   387.                      store_symbol(CN_TR(next_case(the_FW.current_case)), w, c);
   388.                      size := size + 1;
   389.                      the_FW.current_case := the_FW.current_case xor 1;
   390.                      back_off(the_FW.stream);
   391.                   else
   392.                      if the_FW.current_case = KDF9.Case_Normal then
   393.                         symbol := CN_TR(char);
   394.                      else
   395.                         symbol := CS_TR(char);
   396.                      end if;
   397.                      store_symbol(symbol, w, c);
   398.                      size := size + 1;
   399.                      if transfer_to_EM and symbol = KDF9.End_Message then
   400.                         for d in 1 .. 7-c loop
   401.                            store_symbol(KDF9.Blank_Space, w, c+d);
   402.                         end loop;
   403.                         exit word_loop;
   404.                      end if;
   405.                   end if;
   406.             end case;
   407.          end loop;
   408.       end loop word_loop;
   409.       flush(the_FW.output, the_pause);
   410.       set_text_colour_to_black(the_FW.output);
   411.       do_output_housekeeping(the_FW, written => size-fill, fetched => size);
   412.    exception
   413.       when end_of_stream =>
   414.          flush(the_FW.output, the_pause);
   415.          set_text_colour_to_black(the_FW.output);
   416.          do_output_housekeeping(the_FW, written => size-fill, fetched => size);
   417.    end put_symbols;
   418.
   419.    overriding
   420.    procedure write (the_FW    : in out FW.device;
   421.                     Q_operand : in KDF9.Q_register) is
   422.    begin
   423.       put_symbols(the_FW, Q_operand, transfer_to_EM => False);
   424.    end write;
   425.
   426.    overriding
   427.    procedure write_to_EM (the_FW    : in out FW.device;
   428.                           Q_operand : in KDF9.Q_register) is
   429.    begin
   430.       put_symbols(the_FW, Q_operand, transfer_to_EM => True);
   431.    end write_to_EM;
   432.
   433.    -- TWQq
   434.    overriding
   435.    procedure POA (the_FW      : in out FW.device;
   436.                   Q_operand   : in KDF9.Q_register;
   437.                   set_offline : in Boolean) is
   438.    begin
   439.       initialize_byte_mode_transfer(the_FW, Q_operand, set_offline);
   440.       write(the_FW, Q_operand);
   441.       set_lockouts(Q_operand);
   442.       reset(the_FW.stream);
   443.       if Q_operand = (0, 8#27#, 8#27#) and the_CPU_state = Director_state then
   444.          -- Allow just one "FAILS" message from Director
   445.          raise Director_failure with "too many FAILS";
   446.       end if;
   447.    end POA;
   448.
   449.    -- TWEQq
   450.    overriding
   451.    procedure POB (the_FW      : in out FW.device;
   452.                   Q_operand   : in KDF9.Q_register;
   453.                   set_offline : in Boolean) is
   454.    begin
   455.       initialize_byte_mode_transfer(the_FW, Q_operand, set_offline);
   456.       write_to_EM(the_FW, Q_operand);
   457.       set_lockouts(Q_operand);
   458.       reset(the_FW.stream);
   459.    end POB;
   460.
   461.    procedure put_words (the_FW         : in out FW.device;
   462.                         Q_operand      : in KDF9.Q_register;
   463.                         transfer_to_EM : in Boolean := False) is
   464.       start_address : constant KDF9.address := Q_operand.I;
   465.       end_address   : constant KDF9.address := Q_operand.M;
   466.       size : KDF9.word := 0;
   467.       word : KDF9.word;
   468.       char : Character;
   469.    begin
   470.       validate_range_access(start_address, end_address);
   471.       set_the_duration_of_the_pause(the_FW);
   472.       the_FW.mode := the_flexowriter_is_writing;
   473.       set_text_colour_to_red(the_FW.output);
   474.       for w in start_address .. end_address loop
   475.          case the_FW.mode is
   476.             when the_flexowriter_is_writing =>
   477.                word := fetch_word(w) and 8#377#;
   478.                size := size + 1;
   479.                char := Character'Val(word);
   480.                if (word and 8#77#) = KDF9.word(KDF9.Semi_Colon) then
   481.                   -- Hypothesis: POC and POD act like POA and POB with respect to prompting;
   482.                   --    and change from writing to reading after the output of any word that has
   483.                   --       the KDF9 code for a semicolon in its least significant 6 bits.
   484.                   flush(the_FW.output, the_pause);
   485.                   set_text_colour_to_black(the_FW.output);
   486.                   put_byte(';', the_FW.output);
   487.                   flush(the_FW.output, the_pause);
   488.                   inject_a_response(the_FW, neat(contents(the_FW.output)), size);
   489.                   the_FW.mode := the_flexowriter_is_reading;
   490.                else
   491.                   put_char(char, the_FW.output);
   492.                end if;
   493.                exit when transfer_to_EM and (word and 8#77#) = KDF9.word(KDF9.End_Message);
   494.             when the_flexowriter_is_reading =>
   495.                get_char(char, the_FW.stream);
   496.                size := size + 1;
   497.                word := KDF9.word(Character'Pos(char));
   498.                store_word(word, w);
   499.                exit when transfer_to_EM and char = E_M;
   500.          end case;
   501.       end loop;
   502.       flush(the_FW.output, the_pause);
   503.       set_text_colour_to_black(the_FW.output);
   504.       do_output_housekeeping(the_FW, written => size, fetched => size);
   505.    exception
   506.       when end_of_stream =>
   507.          flush(the_FW.output, the_pause);
   508.          set_text_colour_to_black(the_FW.output);
   509.          do_output_housekeeping(the_FW, written => size, fetched => size);
   510.    end put_words;
   511.
   512.    overriding
   513.    procedure words_write (the_FW    : in out FW.device;
   514.                           Q_operand : in KDF9.Q_register) is
   515.    begin
   516.       put_words(the_FW, Q_operand, transfer_to_EM => False);
   517.    end words_write;
   518.
   519.    overriding
   520.    procedure words_write_to_EM (the_FW    : in out FW.device;
   521.                                 Q_operand : in KDF9.Q_register) is
   522.    begin
   523.       put_words(the_FW, Q_operand, transfer_to_EM => True);
   524.    end words_write_to_EM;
   525.
   526.    -- TWCQq
   527.    overriding
   528.    procedure POC (the_FW      : in out FW.device;
   529.                   Q_operand   : in KDF9.Q_register;
   530.                   set_offline : in Boolean) is
   531.    begin
   532.       initialize_byte_mode_transfer(the_FW, Q_operand, set_offline);
   533.       words_write(the_FW, Q_operand);
   534.       set_lockouts(Q_operand);
   535.    end POC;
   536.
   537.    -- TWECQq
   538.    overriding
   539.    procedure POD (the_FW      : in out FW.device;
   540.                   Q_operand   : in KDF9.Q_register;
   541.                   set_offline : in Boolean) is
   542.    begin
   543.       initialize_byte_mode_transfer(the_FW, Q_operand, set_offline);
   544.       words_write_to_EM(the_FW, Q_operand);
   545.       set_lockouts(Q_operand);
   546.    end POD;
   547.
   548.    FW_quantum : constant := 1E6 / 10;  -- 10 characters per second.
   549.
   550.    -- This is the monitor console Flexowriter.
   551.
   552.    FW0 : aliased FW.device (FW0_number,
   553.                             kind    => FW_kind,
   554.                             unit    => 0,
   555.                             quantum => FW_quantum,
   556.                             is_slow => True);
   557.    pragma Unreferenced(FW0);
   558.
   559. end IOC.two_shift.FW;

Compiling: ../Source\ioc-two_shift-fw.ads
Source file time stamp: 2015-06-18 00:56:24
Compiled at: 2015-10-28 18:14:34

     1. -- IOC-shift_devices-fw.ads
     2. --
     3. -- Emulation of a FlexoWriter buffer: monitor typewriter functionality.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package IOC.two_shift.FW is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    type device is new IOC.two_shift.device with private;
    24.
    25.    function a_LF_was_just_read (the_FW : FW.device)
    26.    return Boolean;
    27.
    28.    -- TRQq
    29.    overriding
    30.    procedure PIA (the_FW      : in out FW.device;
    31.                   Q_operand   : in KDF9.Q_register;
    32.                   set_offline : in Boolean);
    33.    -- TREQq
    34.    overriding
    35.    procedure PIB (the_FW      : in out FW.device;
    36.                   Q_operand   : in KDF9.Q_register;
    37.                   set_offline : in Boolean);
    38.    -- TRCQq character read
    39.    overriding
    40.    procedure PIC (the_FW      : in out FW.device;
    41.                   Q_operand   : in KDF9.Q_register;
    42.                   set_offline : in Boolean);
    43.    -- TRECQq character read to End_Message
    44.    overriding
    45.    procedure PID (the_FW      : in out FW.device;
    46.                   Q_operand   : in KDF9.Q_register;
    47.                   set_offline : in Boolean);
    48.    -- as PIA
    49.    overriding
    50.    procedure PIE (the_FW      : in out FW.device;
    51.                   Q_operand   : in KDF9.Q_register;
    52.                   set_offline : in Boolean);
    53.    -- as PIB
    54.    overriding
    55.    procedure PIF (the_FW      : in out FW.device;
    56.                   Q_operand   : in KDF9.Q_register;
    57.                   set_offline : in Boolean);
    58.    -- as PIC
    59.    overriding
    60.    procedure PIG (the_FW      : in out FW.device;
    61.                   Q_operand   : in KDF9.Q_register;
    62.                   set_offline : in Boolean);
    63.    -- as PID
    64.    overriding
    65.    procedure PIH (the_FW      : in out FW.device;
    66.                   Q_operand   : in KDF9.Q_register;
    67.                   set_offline : in Boolean);
    68.
    69.    -- TWQq
    70.    overriding
    71.    procedure POA (the_FW      : in out FW.device;
    72.                   Q_operand   : in KDF9.Q_register;
    73.                   set_offline : in Boolean);
    74.    -- TWEQq
    75.    overriding
    76.    procedure POB (the_FW      : in out FW.device;
    77.                   Q_operand   : in KDF9.Q_register;
    78.                   set_offline : in Boolean);
    79.
    80.    -- NB the following assumes that page 285 of the Manual is erroneous,
    81.    -- and that POC and POD for the Flexowriter are analogous to the tape punch,
    82.    -- as other sources, such as the "Usecode Digest", do in fact indicate.
    83.
    84.    -- TWCQq character write
    85.    overriding
    86.    procedure POC (the_FW      : in out FW.device;
    87.                   Q_operand   : in KDF9.Q_register;
    88.                   set_offline : in Boolean);
    89.    -- TWECQq character write to End_Message
    90.    overriding
    91.    procedure POD (the_FW      : in out FW.device;
    92.                   Q_operand   : in KDF9.Q_register;
    93.                   set_offline : in Boolean);
    94.
    95. private
    96.
    97.    type flexowriter_mode is
    98.       (the_flexowriter_is_reading, the_flexowriter_is_writing);
    99.
   100.    -- The Flexowriter has separate input and output streams, to accommodate the console I/O API
   101.    --    of MS Windows, which requires separate pseudo-devices for input and output.
   102.    type device is new IOC.two_shift.device with
   103.       record
   104.          output : IO.stream;
   105.          mode   : FW.flexowriter_mode;
   106.       end record;
   107.
   108.    overriding
   109.    procedure Initialize (the_FW : in out FW.device);
   110.
   111.    overriding
   112.    procedure Finalize (the_FW : in out FW.device);
   113.
   114.    overriding
   115.    procedure do_output_housekeeping (the_FW   : in out FW.device;
   116.                                     written,
   117.                                     fetched  : in KDF9.word);
   118.
   119.    overriding
   120.    procedure write (the_FW    : in out FW.device;
   121.                     Q_operand : in KDF9.Q_register);
   122.
   123.    overriding
   124.    procedure write_to_EM (the_FW    : in out FW.device;
   125.                           Q_operand : in KDF9.Q_register);
   126.
   127.    overriding
   128.    procedure words_write (the_FW    : in out FW.device;
   129.                           Q_operand : in KDF9.Q_register);
   130.
   131.    overriding
   132.    procedure words_write_to_EM (the_FW    : in out FW.device;
   133.                                 Q_operand : in KDF9.Q_register);
   134.
   135. end IOC.two_shift.FW;

 559 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\kdf9-cpu.adb
Source file time stamp: 2015-06-18 00:56:12
Compiled at: 2015-10-28 18:14:37

     1. -- kdf9-cpu.adb
     2. --
     3. -- Support for KDF9 CPU/ALU operations that are not automatically inherited from
     4. --   Ada types; and for types used in the internal functioning of the microcode.
     5. --
     6. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     7. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     8. --
     9. -- The ee9 program is free software; you can redistribute it and/or
    10. -- modify it under terms of the GNU General Public License as published
    11. -- by the Free Software Foundation; either version 3, or (at your option)
    12. -- any later version. This program is distributed in the hope that it
    13. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    14. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    15. -- See the GNU General Public License for more details. You should have
    16. -- received a copy of the GNU General Public License distributed with
    17. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    18. --
    19.
    20. package body KDF9.CPU is
    21.
    22.    -- Count the leading zeros of the absolute value of y, omitting the sign bit.
    23.    -- If y is 0, return 47.
    24.    function nr_leading_zeros (y : KDF9.word)
    25.    return Natural is
    26.       x : CPU.u_64;
    27.       r : Natural;
    28.    begin
    29.       if y = 0 then return 47; end if;
    30.       if resign(y) < 0 then
    31.          x := CPU.u_64(16#FFFF_FFFF_FFFF# and not y);
    32.       else
    33.          x := CPU.u_64(y);
    34.       end if;
    35.       if (x and 16#FFFF_0000_0000#) /= 0 then
    36.          r := 32; x := shift_right(x, 32);
    37.       elsif (x and 16#0000_FFFF_0000#) /= 0 then
    38.          r := 16; x := shift_right(x, 16);
    39.       else
    40.          r := 0;
    41.       end if;
    42.       if (x and 16#0000_0000_FF00#) /= 0 then
    43.          r := r + 8; x := shift_right(x, 8);
    44.       end if;
    45.       if (x and 16#0000_0000_00F0#) /= 0 then
    46.          r := r + 4; x := shift_right(x, 4);
    47.       end if;
    48.       if (x and 16#0000_0000_000C#) /= 0 then
    49.          r := r + 2; x := shift_right(x, 2);
    50.       end if;
    51.       if (x and 16#0000_0000_0002#) /= 0 then
    52.          r := r + 1;
    53.       end if;
    54.       r := 47 - r - 1;  -- -1 discounts the sign bit.
    55.       return r;
    56.    end nr_leading_zeros;
    57.
    58.    function nr_one_bits (u : CPU.u_64)
    59.    return CPU.u_64 is
    60.       n : CPU.u_64 := shift_right(u, 1) and 16#77_77_77_77_77_77_77_77#;
    61.       x : CPU.u_64 := u - n;
    62.    begin
    63.       n := shift_right(n, 1) and 16#77_77_77_77_77_77_77_77#;
    64.       x := x - n;
    65.       n := shift_right(n, 1) and 16#77_77_77_77_77_77_77_77#;
    66.       x := x - n;
    67.       x := (x + shift_right(x, 4)) and 16#0F_0F_0F_0F_0F_0F_0F_0F#;
    68.       x := x * 16#01_01_01_01_01_01_01_01#;
    69.       return shift_right(x, CPU.u_64'Size-8);
    70.    end nr_one_bits;
    71.
    72.
    73. --
    74. -- KDF9 Arithmetic Control (AC) primitives
    75. --
    76.
    77.    KDF9_max_signed : constant CPU.s_64 := CPU.s_64(CPU.signed'Last);
    78.    KDF9_min_signed : constant CPU.s_64 := CPU.s_64(CPU.signed'First);
    79.
    80.    function as_word (u : CPU.u_64)
    81.    return KDF9.word is
    82.    begin
    83.       return KDF9.word(u and KDF9.word_mask);
    84.    end as_word;
    85.
    86.    function as_word (s : CPU.s_64)
    87.    return KDF9.word is
    88.    begin
    89.       if s > KDF9_max_signed or s < KDF9_min_signed then
    90.          the_V_bit := 1;
    91.       end if;
    92.       return as_word(unsign(s));
    93.    end as_word;
    94.
    95.    function contracted (msw, lsw : KDF9.word)
    96.    return KDF9.word is
    97.    begin
    98.       if resign(lsw) < 0 or (msw+1) > 1 then
    99.          the_V_bit := 1;
   100.       end if;
   101.       return (lsw and not_sign_bit) or (msw and sign_bit);
   102.    end contracted;
   103.
   104.    function contracted (P : KDF9.pair)
   105.    return KDF9.word is
   106.    begin
   107.       return contracted(msw => P.msw, lsw => P.lsw);
   108.    end contracted;
   109.
   110.    function shift_time (amount : Natural)
   111.    return KDF9.microseconds is
   112.    begin
   113.       return KDF9.microseconds(amount/16 + amount/8 mod 2 + Boolean'Pos(amount mod 8 > 0));
   114.    end shift_time;
   115.
   116.    function shift_word_left (W : KDF9.word; amount : word_shift_length)
   117.    return KDF9.word is
   118.    begin
   119.       return as_word(shift_left(CPU.u_64(W), amount));
   120.    end shift_word_left;
   121.
   122.    function shift_word_right (W : KDF9.word; amount : word_shift_length)
   123.    return KDF9.word is
   124.    begin
   125.       return KDF9.word(shift_right(CPU.u_64(W), amount));  -- This cannot be out of range.
   126.    end shift_word_right;
   127.
   128.    function rotate_word_left (W : KDF9.word; amount : word_shift_length)
   129.    return KDF9.word is
   130.    begin
   131.       return shift_word_left(W, amount) or shift_word_right(W, 48-amount);
   132.    end rotate_word_left;
   133.
   134.    function rotate_word_right (W : KDF9.word; amount : word_shift_length)
   135.    return KDF9.word is
   136.    begin
   137.       return shift_word_right(W, amount) or shift_word_left(W, 48-amount);
   138.    end rotate_word_right;
   139.
   140.    function shift_circular (W : KDF9.word; L : CPU.signed_Q_part)
   141.    return KDF9.word is
   142.    begin
   143.       -- The logic here conforms to ¶1.1 of EE Report K/GD.y.80, entitled
   144.       --    "KDF 9: SHIFTING AND SHIFT CONTROL".
   145.       -- Circular shifts were implemented by duplicating the operand, doing a double-length
   146.       --    shift of the two words, and selecting the appropriate word from the result.
   147.       if abs L > 95 then
   148.          return 0;
   149.       elsif L < -48 then
   150.          return shift_word_right(W, Natural(-L-48));
   151.       elsif L > +48 then
   152.          return shift_word_left(W, Natural(+L-48));
   153.       elsif L < 0 then
   154.          return rotate_word_right(W, Natural(-L));
   155.       else
   156.          return rotate_word_left(W, Natural(L));
   157.       end if;
   158.    end shift_circular;
   159.
   160.    function shift_logical (W : KDF9.word; L : CPU.signed_Q_part)
   161.    return KDF9.word is
   162.    begin
   163.       if abs L > 47 then
   164.          return 0;
   165.       elsif L < 0 then
   166.          return shift_word_right(W, Natural(-L));
   167.       else
   168.          return shift_word_left(W, Natural(L));
   169.       end if;
   170.    end shift_logical;
   171.
   172.    function shift_pair_left (P : KDF9.pair; L : Natural)
   173.    return KDF9.pair;
   174.    pragma Inline(shift_pair_left);
   175.
   176.    function shift_pair_left (P : KDF9.pair; L : Natural)
   177.    return KDF9.pair is
   178.       result    : KDF9.pair;
   179.       crossover : KDF9.word;
   180.    begin
   181.       -- The logic here conforms to ¶3.2 of EE Report K/GD.y.80.
   182.       if L < 48 then
   183.          result.lsw := shift_word_left(P.lsw, L);
   184.          crossover  := shift_word_right(P.lsw, 48-L);
   185.          result.msw := shift_word_left(P.msw, L) or crossover;
   186.       else
   187.          result.lsw := 0;
   188.          result.msw := shift_word_left(P.lsw, L-48);
   189.       end if;
   190.       return result;
   191.    end shift_pair_left;
   192.
   193.    function shift_pair_right (P : KDF9.pair; L : Natural)
   194.    return KDF9.pair;
   195.    pragma Inline(shift_pair_right);
   196.
   197.    function shift_pair_right (P : KDF9.pair; L : Natural)
   198.    return KDF9.pair is
   199.       result    : KDF9.pair;
   200.       crossover : KDF9.word;
   201.    begin
   202.       -- The logic here conforms to ¶3.2 of EE Report K/GD.y.80.
   203.       if L < 48 then
   204.          result.msw := shift_word_right(P.msw, L);
   205.          crossover  := shift_word_left(P.msw, 48-L);
   206.          result.lsw := shift_word_right(P.lsw, L) or crossover;
   207.       else
   208.          result.msw := 0;
   209.          result.lsw := shift_word_right(P.msw, L-48);
   210.       end if;
   211.       return result;
   212.    end shift_pair_right;
   213.
   214.    function shift_logical (P : KDF9.pair; L : CPU.signed_Q_part)
   215.    return KDF9.pair is
   216.    begin
   217.       if L > 0 then
   218.          return shift_pair_left(P, Natural(L));
   219.       elsif L < 0 then
   220.          return shift_pair_right(P, Natural(-L));
   221.       else
   222.          return P;
   223.       end if;
   224.    end shift_logical;
   225.
   226.    function scale_down (W : KDF9.word; amount : Natural)
   227.    return KDF9.word is
   228.       unrounded, clearing : CPU.u_64;
   229.    begin
   230.       if amount = 0 then
   231.          return W;
   232.       elsif amount > 46 then
   233.          if resign(W) < 0 then
   234.             return KDF9.all_one_bits;
   235.          else
   236.             return 0;
   237.          end if;
   238.       else
   239.          -- It is undefined whether the intrinsic shift_right_arithmetic function,
   240.          --    operating on CPU.u_64, yields a rounded result.
   241.          -- So, any rounding it might do is completely suppressed.
   242.          unrounded := shift_right_arithmetic(shift_left(CPU.u_64(W),16), 16);
   243.          clearing  := - shift_left(1, amount);
   244.          return as_word(shift_right_arithmetic(unrounded and clearing, amount));
   245.       end if;
   246.    end scale_down;
   247.
   248.    function scale_down_and_round (W : KDF9.word; amount : Natural)
   249.    return KDF9.word is
   250.       unrounded, clearing, rounding : CPU.u_64;
   251.    begin
   252.       if amount = 0 then
   253.          return W;
   254.       elsif amount > 46 then
   255.          if resign(W) < 0 then
   256.             return KDF9.all_one_bits;
   257.          else
   258.             return 0;
   259.          end if;
   260.       else
   261.          -- It is undefined whether the intrinsic shift_right_arithmetic,
   262.          --    operating on CPU.u_64, yields a rounded result.
   263.          -- So, any rounding it might do is suppressed,
   264.          --    and correct rounding is explicitly computed.
   265.          unrounded := shift_right_arithmetic(shift_left(CPU.u_64(W),16), 16);
   266.          rounding  := shift_right(unrounded, amount-1) and 1;
   267.          clearing  := - shift_left(1, amount);
   268.          unrounded := unrounded and clearing;
   269.          return as_word(shift_right_arithmetic(unrounded, amount) + rounding);
   270.       end if;
   271.    end scale_down_and_round;
   272.
   273.    function scale_up (W : KDF9.word; amount : Natural)
   274.    return KDF9.word is
   275.       M : constant Natural := Natural'Min(amount, 47);
   276.    begin
   277.       if resign(W) < 0 then
   278.          if scale_down(W, 47-M) /= all_one_bits or
   279.                resign(shift_word_left(W, M)) >= 0 then
   280.             -- See EE Report K/GD.y.80., ¶ 1.1.
   281.             the_V_bit := 1;
   282.          end if;
   283.          return shift_word_left(W, M);
   284.       else
   285.          if shift_word_right(W, 47-M) /= all_zero_bits or
   286.                resign(shift_word_left(W, M)) < 0 then
   287.             -- See EE Report K/GD.y.80., ¶ 1.1.
   288.             the_V_bit := 1;
   289.          end if;
   290.          return shift_word_left(W, M);
   291.       end if;
   292.    end scale_up;
   293.
   294.    function shift_arithmetic (I : KDF9.word; L : CPU.signed_Q_part)
   295.    return KDF9.word is
   296.    begin
   297.       if L < 0 then
   298.          return scale_down_and_round(I, Natural(-L));
   299.       else
   300.          return scale_up(I, Natural(L));
   301.       end if;
   302.    end shift_arithmetic;
   303.
   304.    function scale_up (P : KDF9.pair; L : Natural)
   305.    return KDF9.pair is
   306.       result    : KDF9.pair;
   307.       crossover : KDF9.word;
   308.    begin
   309.       -- The logic here conforms to ¶3.2 of EE Report K/GD.y.80.
   310.       if L < 48 then
   311.          result.lsw := shift_word_left(P.lsw, L) and KDF9.max_word;
   312.          crossover  := shift_word_right(P.lsw and KDF9.max_word, 47-L);
   313.          result.msw := scale_up(P.msw, L) or crossover;
   314.       else
   315.          result.lsw := 0;
   316.          result.msw := scale_up(P.msw, 47) or P.lsw;
   317.          result.msw := scale_up(result.msw, Natural'Min(L, 94)-47);
   318.       end if;
   319.       return result;
   320.    end scale_up;
   321.
   322.    function scale_down (P : KDF9.pair; L : Natural)
   323.    return KDF9.pair is
   324.       result    : KDF9.pair;
   325.       crossover : KDF9.word;
   326.    begin
   327.       -- The logic here conforms to ¶3.2 of EE Report K/GD.y.80.
   328.       -- SHAD-n does NOT round, according to the Manual.
   329.       if L < 48 then
   330.          result.msw := scale_down(P.msw, L);
   331.          crossover  := shift_word_left(P.msw, 47-L);
   332.          result.lsw := (shift_word_right(P.lsw, L) or crossover) and KDF9.max_word;
   333.       else
   334.          result.msw := scale_down(P.msw, 47);
   335.          result.lsw := shift_word_right(P.msw, Natural'Min(L, +94)-47) and KDF9.max_word;
   336.       end if;
   337.       return result;
   338.    end scale_down;
   339.
   340.    function shift_arithmetic (P : KDF9.pair; L : CPU.signed_Q_part)
   341.    return KDF9.pair is
   342.    begin
   343.       if L < 0 then
   344.          return scale_down(P, Natural(-L));
   345.       elsif L > 0 then
   346.          return scale_up(P, Natural(L));
   347.       else -- L = 0
   348.          return P; -- See ¶1.1 of EE Report K/GD.y.80: this avoids clearing D0 of P.lsw.
   349.       end if;
   350.    end shift_arithmetic;
   351.
   352.    procedure normalize (fraction, exponent : in out KDF9.word) is
   353.       sign_flag  : constant KDF9.word := shift_word_right(fraction and sign_bit, 1);
   354.       normalizer : Natural;
   355.    begin
   356.       if fraction = 0 then
   357.          exponent := 2#10_000_000#;  -- This yields 0 when biased positive.
   358.          return;
   359.       end if;
   360.
   361.       normalizer := nr_leading_zeros(fraction);
   362.
   363.       -- shift_word_left is used, not _arithmetic, as D[1..normalizer] = D0
   364.       fraction := shift_word_left(fraction, normalizer);
   365.       exponent := exponent - KDF9.word(normalizer);
   366.       the_CPU_delta := the_CPU_delta + shift_time(normalizer);
   367.
   368.       -- scale_down_and_round may round up and overflow the fraction bits ...
   369.       fraction := scale_down_and_round(fraction, 8);
   370.       if (fraction and overflow_mask) /= shift_word_right(sign_flag, 7) then
   371.           -- ... so re-normalize; scale_down cannot round here.
   372.          fraction := scale_down(fraction, 1);
   373.          exponent := exponent + 1;
   374.          the_CPU_delta := the_CPU_delta + 1;
   375.       end if;
   376.       fraction := fraction and mantissa_mask;
   377.
   378.       if resign(exponent) < -128 then
   379.          -- Deal with underflow.
   380.          fraction := 0;
   381.          exponent := 2#10_000_000#;  -- This yields 0 when biased positive.
   382.       elsif resign(exponent) > +127 then
   383.          -- Deal with overflow.
   384.          the_V_bit := 1;
   385.          exponent := 2#01_111_111#;
   386.       end if;
   387.    end normalize;
   388.
   389.    function fraction_word (mantissa : CPU.float)
   390.    return KDF9.word is
   391.       M : constant KDF9.word := as_word(mantissa);
   392.       S  : constant KDF9.word := M and sign_bit;
   393.    begin
   394.       -- shift_word_left is used instead of scale_up to avoid a spurious overflow.
   395.       return (shift_word_left(M, 8) and KDF9.max_word) or S;
   396.    end fraction_word;
   397.
   398.    function masked_mantissa (F : CPU.float)
   399.    return CPU.float is
   400.    begin
   401.       return as_float(as_word(F) and mantissa_mask);
   402.    end masked_mantissa;
   403.
   404.    function scaler (F : CPU.float)
   405.    return KDF9.word is
   406.    begin
   407.       return (shift_word_right(as_word(F), 39) and 2#11_111_111#) - 128;
   408.    end scaler;
   409.
   410.    function normalized (full_fraction, scaler : KDF9.word)
   411.    return CPU.float is
   412.       E : KDF9.word := scaler;
   413.       F : KDF9.word := full_fraction;
   414.    begin
   415.       normalize(fraction => F, exponent => E);
   416.       return CPU.float(shift_word_left((E + 128) and 2#11_111_111#, 39) or F);
   417.    end normalized;
   418.
   419.    function normalized  (R : CPU.float)
   420.    return CPU.float is
   421.       E : constant KDF9.word := scaler(R);
   422.       F : constant KDF9.word := fraction_word(R);
   423.    begin
   424.       return normalized(full_fraction => F, scaler => E);
   425.    end normalized;
   426.
   427.    function cardinality (W : KDF9.word)
   428.    return KDF9.word is
   429.    begin
   430.       return KDF9.word(nr_one_bits(CPU.u_64(W)));
   431.    end cardinality;
   432.
   433.    function "-" (I : CPU.signed)
   434.    return KDF9.word is
   435.       result : constant CPU.s_64 := -CPU.s_64(I);
   436.    begin
   437.       return as_word(result);
   438.    end "-";
   439.
   440.    function "abs" (I : CPU.signed)
   441.    return KDF9.word is
   442.       result : constant CPU.s_64 := abs CPU.s_64(I);
   443.    begin
   444.       return as_word(result);
   445.    end "abs";
   446.
   447.    function "+" (L, R : CPU.signed)
   448.    return KDF9.word is
   449.       result : constant CPU.s_64 := CPU.s_64(L) + CPU.s_64(R);
   450.    begin
   451.       return as_word(result);
   452.    end "+";
   453.
   454.    function "-" (L, R : CPU.signed)
   455.    return KDF9.word is
   456.       result : constant CPU.s_64 := CPU.s_64(L) - CPU.s_64(R);
   457.    begin
   458.       return as_word(result);
   459.    end "-";
   460.
   461.    function "*" (L, R : CPU.signed)
   462.    return KDF9.word is
   463.    begin
   464.       return contracted(KDF9.pair'(unsign(L) * unsign(R)));
   465.    end "*";
   466.
   467.    procedure do_DIVI (L : in KDF9.word;
   468.                       R : in KDF9.word;
   469.                       Quotient, Remainder : out KDF9.word) is
   470.    begin
   471.       if R /= 0 then
   472.          Remainder := as_word(CPU.s_64(resign(L)) mod CPU.s_64(resign(R)));
   473.          Quotient  :=
   474.             as_word((CPU.s_64(resign(L)) - CPU.s_64(resign(Remainder))) / CPU.s_64(resign(R)));
   475.       else
   476.          the_V_bit := 1;
   477.          Quotient  := L;  -- ??
   478.          Remainder := R;  -- ??
   479.       end if;
   480.    end do_DIVI;
   481.
   482.    function "*" (L, R : KDF9.word)
   483.    return CPU.fraction is
   484.    begin
   485.       if L = sign_bit and R = sign_bit then
   486.          the_V_bit := 1;
   487.          return fractional(sign_bit);  -- The only case is L = R = -1.0 = L*R.
   488.       else
   489.          return fractional(L) * fractional(R);
   490.       end if;
   491.    end "*";
   492.
   493.    function "/" (L, R : KDF9.word)
   494.    return CPU.fraction is
   495.    begin
   496.       if R = 0 or L = sign_bit then
   497.          the_V_bit := 1;
   498.          return fractional(L); -- ??
   499.       elsif R = sign_bit then
   500.          return -fractional(L);
   501.       elsif abs fractional(L) < abs fractional(R) then  -- abs is safe now.
   502.          return fractional(L) / fractional(R);
   503.       else
   504.          the_V_bit := 1;
   505.          return fractional(L); -- ??
   506.       end if;
   507.    end "/";
   508.
   509.    function "+" (L, R : KDF9.pair)
   510.    return KDF9.pair is
   511.       carry, sum : CPU.s_64;
   512.       result     : KDF9.pair;
   513.    begin
   514.       sum := CPU.s_64(L.lsw) + CPU.s_64(R.lsw);
   515.       if unsign(sum) > KDF9.max_word then -- carry into msw
   516.          carry := 1;
   517.          result.lsw := KDF9.word(unsign(sum) and KDF9.max_word);
   518.       else
   519.          carry := 0;
   520.          result.lsw := KDF9.word(sum);
   521.       end if;
   522.       sum := CPU.s_64(resign(L.msw)) + CPU.s_64(resign(R.msw)) + carry;
   523.       result.msw := as_word(sum);
   524.       return result;
   525.    end "+";
   526.
   527.    function "-" (J : KDF9.pair)
   528.    return KDF9.pair is
   529.       borrow,
   530.       negative : CPU.s_64;
   531.       result   : KDF9.pair;
   532.    begin
   533.       negative := - CPU.s_64(J.lsw);
   534.       if unsign(negative) > KDF9.max_word then -- borrow from msw
   535.          borrow := 1;
   536.          result.lsw := KDF9.word(unsign(negative) and KDF9.max_word);
   537.       else
   538.          borrow := 0;
   539.          result.lsw := KDF9.word(negative);
   540.       end if;
   541.       negative := - CPU.s_64(resign(J.msw)) - borrow;
   542.       result.msw := as_word(negative);
   543.       return result;
   544.    end "-";
   545.
   546.    function "-" (L, R : KDF9.pair)
   547.    return KDF9.pair is
   548.       borrow,
   549.       difference : CPU.s_64;
   550.       result     : KDF9.pair;
   551.    begin
   552.       difference := CPU.s_64(L.lsw) - CPU.s_64(R.lsw);
   553.       if unsign(difference) > KDF9.max_word then -- borrow from msw
   554.          borrow := 1;
   555.          result.lsw := KDF9.word(unsign(difference) and KDF9.max_word);
   556.       else
   557.          borrow := 0;
   558.          result.lsw := KDF9.word(difference);
   559.       end if;
   560.       difference := CPU.s_64(resign(L.msw)) - CPU.s_64(resign(R.msw)) - borrow;
   561.       result.msw := as_word(difference);
   562.       return result;
   563.    end "-";
   564.
   565.    function "*" (L, R : KDF9.word)
   566.    return KDF9.pair is
   567.       S, T, U, V, W : KDF9.word;
   568.       H, M, B       : KDF9.pair;
   569.    begin
   570.       if L = sign_bit then
   571.          if R = L then
   572.             -- L*R = (+1.0), which is not a valid fraction, so deal with overflow.
   573.             the_V_bit := 1;
   574.             return (L, 0);
   575.          else
   576.             -- L*R = -R.
   577.             return - (R, 0);
   578.          end if;
   579.       end if;
   580.       if R = sign_bit then
   581.          -- L*R = -L.
   582.          return - (L, 0);
   583.       end if;
   584.       -- Now it is safe to take absolute values, as they cannot overflow.
   585.       S := scale_down(abs resign(L), 24);
   586.       T := abs resign(L) and halfword_mask;
   587.       U := scale_down(abs resign(R), 24);
   588.       V := abs resign(R) and halfword_mask;
   589.       H := ((S*U)*2, 0);
   590.       M := scale_down((KDF9.word'(S*V), 0), 1) + scale_down((KDF9.word'(T*U), 0), 1);
   591.       M := scale_down(M, 22);
   592.       W := rotate_word_left(KDF9.word'(T*V), 1);
   593.       B := (W and 1, shift_word_right(W, 1));
   594.       if resign(L xor R) < 0 then
   595.          return - (H + M + B);
   596.       else
   597.          return    H + M + B;
   598.       end if;
   599.    end "*";
   600.
   601.    host_small : constant := 2.0**(-63);
   602.    type f_64 is delta host_small range -1.0 .. +1.0 - host_small;
   603.    for f_64'Size use CPU.s_64'Size;
   604.
   605.    function scale_up (f : CPU.f_64; N : Natural)
   606.    return f_64 is
   607.    begin
   608.       return f * 2**N;
   609.    end scale_up;
   610.
   611.    function scale_down (f : CPU.f_64; N : Natural)
   612.    return f_64 is
   613.    begin
   614.       if N > 62 then
   615.          return 0.0;
   616.       end if;
   617.       return f / 2**N;
   618.    end scale_down;
   619.
   620.    function to_f_64 (w : KDF9.word)
   621.    return CPU.f_64 is
   622.    begin
   623.       return CPU.f_64(fractional(w));
   624.    end to_f_64;
   625.
   626.    function to_word (f : CPU.f_64)
   627.    return KDF9.word is
   628.    begin
   629.       return integral(CPU.fraction(f));
   630.    end to_word;
   631.
   632.    -- 96 / 48 -> 48-bit, for DIVD, DIVR and DIVDF.
   633.    procedure do_DIVD (L : in KDF9.pair;
   634.                       R : in KDF9.word;
   635.                       Q : out KDF9.word;
   636.                       round : in Boolean := True
   637.                      ) is
   638.       Sl : Natural;
   639.       Sr : Natural;
   640.       Sq : Integer;
   641.       N  : KDF9.pair;
   642.       D  : KDF9.word;
   643.       Ls : CPU.f_64;
   644.       Rs : CPU.f_64;
   645.       Qs : CPU.f_64;
   646.       round_off : CPU.f_64;
   647.    begin
   648.       if R = 0 then
   649.          the_V_bit := 1;
   650.          Q := L.msw; -- ??
   651.          return;
   652.       end if;
   653.       if (L.msw or L.lsw) = 0 then
   654.          Q := 0;
   655.          return;
   656.       end if;
   657.
   658.       Sl := nr_leading_zeros(L.msw);
   659.       if Sl > 46 then -- insignificant top half
   660.          N := scale_up(L, 47);
   661.          Sl := nr_leading_zeros(N.msw);
   662.          N := scale_up(N, Sl);
   663.          Sl := Sl + 47;
   664.       else
   665.          N := scale_up(L, Sl);
   666.       end if;
   667.
   668.       Sr := nr_leading_zeros(R);
   669.       D := scale_up(R, Sr);
   670.
   671.       -- Scale Ls and Rs so that the division cannot overflow.
   672.       Ls := scale_down(to_f_64(N.msw), 2);
   673.       Rs := scale_down(to_f_64(D), 1);
   674.
   675.       Qs := Ls / Rs;  -- "/" cannot overflow here.
   676.
   677.       Sq := 1 + Sr - Sl;
   678.
   679.       if round then
   680.          if Sq < 0 then
   681.             if Sq < -47 then
   682.                round_off := 0.0;
   683.             else
   684.                round_off := scale_up(CPU.fraction'Delta/2, -Sq);
   685.             end if;
   686.          else
   687.             round_off := scale_down(CPU.fraction'Delta/2, Sq);
   688.          end if;
   689.          if Qs > 0.0 then
   690.             Qs := CPU.f_64(CPU.fraction(Qs + round_off));
   691.          else
   692.             Qs := CPU.f_64(CPU.fraction(Qs - round_off));
   693.          end if;
   694.       end if;
   695.
   696.       if Sq < 0 then
   697.          -- Overflow is impossible.
   698.          Qs := scale_down(Qs, -Sq);
   699.       else
   700.          -- If Qs >= 0.5, then L/R >= 1.0 is not a representable result fraction.
   701.          -- If Qs < -0.5, then L/R < -1.0 is not a representable result fraction.
   702.          if Qs >= 0.5 or Qs < -0.5 then
   703.             the_V_bit := 1;
   704.             Q := shift_word_left(to_word(Qs), Sq); -- ??
   705.             return;
   706.          end if;
   707.          if Sq > 0 then
   708.             Qs := scale_up(Qs, Sq);
   709.          end if;
   710.       end if;
   711.
   712.       Q := to_word(Qs);
   713.       return;
   714.    end do_DIVD;
   715.
   716.    -- The Quotient and Remainder of L/R are computed using floor division.
   717.    procedure do_DIVR (L : in KDF9.pair;
   718.                       R : in KDF9.word;
   719.                       Quotient, Remainder : out KDF9.word
   720.                      ) is
   721.    begin
   722.       if R = 0 then
   723.          the_V_bit := 1;
   724.          Quotient  := L.msw;  -- ??
   725.          Remainder := R;      -- ??
   726.       else
   727.          do_DIVD(L, R, Quotient, round => False);
   728.          Remainder := contracted(L - Quotient*R);
   729.       end if;
   730.    end do_DIVR;
   731.
   732.    function host_float (X : CPU.float)
   733.    return Long_Float is
   734.       W : constant KDF9.word  := fraction_word(masked_mantissa(X));
   735.       S : constant Long_Float := 2.0**Integer(resign(scaler(X)));
   736.       F : constant Long_Float := Long_Float(fractional(W)) * S;
   737.    begin
   738.       return F;
   739.    end host_float;
   740.
   741.    -- Assumes that Standard.Long_Float has IEEE 64-bit floating format.
   742.    function as_u_64 is new Ada.Unchecked_Conversion (Long_Float, CPU.u_64);
   743.
   744.    function KDF9_float (X : Long_Float)
   745.    return CPU.float is
   746.       U : constant CPU.u_64 := as_u_64(X);
   747.       E : KDF9.word;
   748.       F : KDF9.word;
   749.       R : CPU.float;
   750.    begin
   751.       if U = 0 then
   752.          return 0;
   753.       end if;
   754.       E := KDF9.word(unsign(CPU.signed(Long_Float'Exponent(X))));
   755.       F := KDF9.word(shift_right(shift_left(U, 11) or 2**63, 17));
   756.       if resign(U) < 0 then
   757.          F := -F;
   758.       end if;
   759.       R := normalized(full_fraction => F, scaler => E);
   760.       if the_V_bit /= 0 then
   761.          raise Constraint_Error;
   762.       end if;
   763.       return R;
   764.    end KDF9_float;
   765.
   766.    -- Round a 48-bit floating-point number to 24-bit format.
   767.    function rounded (R : CPU.float)
   768.    return CPU.float is
   769.    begin
   770.       return normalized(fraction_word(R) + 2**23,  scaler(R));
   771.    end rounded;
   772.
   773.    overriding
   774.    function "-" (R : CPU.float)
   775.    return CPU.float is
   776.       -- F is made half of a true fraction to prevent overflow when negating:
   777.       --    the result exponent is offset by 1, accordingly.
   778.       E : constant KDF9.word := scaler(R) + 1;
   779.       F : KDF9.word := scale_down_and_round(fraction_word(R), 1);
   780.    begin
   781.       F := as_word(CPU.u_64(-F));  -- "-" cannot overflow here.
   782.       return normalized(full_fraction => F, scaler => E);
   783.    end "-";
   784.
   785.    overriding
   786.    function "abs" (R : CPU.float)
   787.    return CPU.float is
   788.    begin
   789.       if resign(KDF9.word(R)) < 0 then
   790.          return - R;
   791.       else
   792.          return R;
   793.       end if;
   794.    end "abs";
   795.
   796.    overriding
   797.    function "+" (L, R : CPU.float)
   798.    return CPU.float is
   799.       -- B and D are made half of a true fraction to prevent overflow when
   800.       --    adding; the result exponent is offset by 1, accordingly.
   801.       A : constant KDF9.word := scaler(R);
   802.       B : KDF9.word := scale_down(fraction_word(R), 1);
   803.       C : constant KDF9.word := scaler(L);
   804.       D : KDF9.word := scale_down(fraction_word(L), 1);
   805.       E : KDF9.word;
   806.       F : KDF9.word;
   807.       N : Natural;
   808.    begin
   809.       if resign(A) >= resign(C) then
   810.          N := Natural'Min(Natural(resign(A-C)), 48);
   811.          D := scale_down_and_round(D, N);
   812.          E := A + 1;
   813.       else
   814.          N := Natural'Min(Natural(resign(C-A)), 48);
   815.          B := scale_down_and_round(B, N);
   816.          E := C + 1;
   817.       end if;
   818.       the_CPU_delta := the_CPU_delta + shift_time(N);
   819.       F := as_word(CPU.u_64(D + B));  -- "+" cannot overflow here.
   820.       return normalized(full_fraction => F, scaler => E);
   821.    end "+";
   822.
   823.    overriding
   824.    function "-" (L, R : CPU.float)
   825.    return CPU.float is
   826.       -- See "+".
   827.       A : constant KDF9.word := scaler(R);
   828.       B : KDF9.word := scale_down(fraction_word(R), 1);
   829.       C : constant KDF9.word := scaler(L);
   830.       D : KDF9.word := scale_down(fraction_word(L), 1);
   831.       E : KDF9.word;
   832.       F : KDF9.word;
   833.       N : Natural;
   834.    begin
   835.       if resign(A) >= resign(C) then
   836.          N := Natural'Min(Natural(resign(A-C)), 48);
   837.          D := scale_down_and_round(D, N);
   838.          E := A + 1;
   839.       else
   840.          N := Natural'Min(Natural(resign(C-A)), 48);
   841.          B := scale_down_and_round(B, N);
   842.          E := C + 1;
   843.       end if;
   844.       the_CPU_delta := the_CPU_delta + shift_time(N);
   845.       F := as_word(CPU.u_64(D - B));  -- "-" cannot overflow here.
   846.       return normalized(full_fraction => F, scaler => E);
   847.    end "-";
   848.
   849.    overriding
   850.    function "*" (L, R : CPU.float)
   851.    return CPU.float is
   852.       B, D, E, F : KDF9.word;
   853.    begin
   854.       if (KDF9.word(L) or KDF9.word(R)) = 0 then
   855.          return 0;
   856.       end if;
   857.       B := fraction_word(R);
   858.       D := fraction_word(L);
   859.       E := scaler(L) + scaler(R);
   860.       if (B = sign_bit) and (B = D) then
   861.          -- D*B = (+1), which is not a valid fraction, so treat specially.
   862.          return normalized(full_fraction => 1, scaler => 47);
   863.       end if;
   864.       F := integral(fractional(D) * fractional(B));  -- "*" cannot overflow here.
   865.       return normalized(full_fraction => F, scaler => E);
   866.    end "*";
   867.
   868.    overriding
   869.    function "/" (L, R : CPU.float)
   870.    return CPU.float is
   871.       D, N   : CPU.fraction;
   872.       Ls, Rs : KDF9.word;
   873.       E, F   : KDF9.word;
   874.    begin
   875.       if R = 0 then
   876.          the_V_bit := 1;
   877.          return L;  -- ?? This result is not well defined in the Manual.
   878.       end if;
   879.       -- If L>=R, L/R>= 1, which is not a valid fraction; so Ls and Rs are
   880.       --    scaled so that the division cannot overflow.
   881.       Ls := scale_down(fraction_word(L), 3);
   882.       Rs := scale_down(fraction_word(R), 1);
   883.       N := abs fractional(Ls);  -- Ls is scaled down by 1/8, so "abs" cannot overflow.
   884.       D := abs fractional(Rs);  -- Rs is scaled down by 1/2, so "abs" cannot overflow.
   885.       -- E is increased by 2 to compensate the quotient's scaling by 1/4.
   886.       E := scaler(L) - scaler(R) + 2;
   887.       F := integral(N / D);  -- "/" cannot overflow here.
   888.       if resign(KDF9.word(L) xor KDF9.word(R)) < 0 then
   889.          -- The result is negative.
   890.          F := -F;
   891.       end if;
   892.       return normalized(full_fraction => F, scaler => E);
   893.    end "/";
   894.
   895.    overriding
   896.    function "<" (L, R : CPU.float)
   897.    return Boolean is
   898.       s : constant KDF9.word := KDF9.word(L) xor KDF9.word(R);
   899.    begin
   900.       if resign(s) < 0 then
   901.          -- The signs differ: L<R iff L is negative.
   902.          return resign(KDF9.word(L)) < 0;
   903.       elsif resign(KDF9.word(L)) < 0 then
   904.          -- L and R are both negative, so invert lexicographical order.
   905.          return not (KDF9.word(L) < KDF9.word(R));
   906.       else
   907.          -- L and R are both non-negative: so use lexicographical order.
   908.          return KDF9.word(L) < KDF9.word(R);
   909.       end if;
   910.    end "<";
   911.
   912.    function fraction_pair (DF : CPU.double)
   913.    return KDF9.pair is
   914.       M : constant KDF9.word := scale_down(fraction_word(DF.msw), 8);
   915.       L : constant KDF9.word := fraction_word(DF.lsw);
   916.    begin
   917.       return scale_up((msw => M, lsw => L), 8);
   918.    end fraction_pair;
   919.
   920.    function scaler (DF : CPU.double)
   921.    return KDF9.word is
   922.    begin
   923.       return scaler(DF.msw);
   924.    end scaler;
   925.
   926.    function rounded (DF : CPU.double)
   927.    return CPU.float is
   928.       fraction : KDF9.pair := fraction_pair(DF) + (0, 2**46);
   929.    begin
   930.       reconstruct(fraction, scaler(DF));
   931.       return CPU.float(fraction.msw);
   932.    end rounded;
   933.
   934.    procedure reconstruct (frac   : in out KDF9.pair;
   935.                           scaler : in KDF9.word) is
   936.       KDF9_exponent :  KDF9.word := scaler + 128;
   937.       normalizer    : Natural;
   938.    begin
   939.       if (frac.msw or frac.lsw) = 0 then
   940.          return; -- frac is already normalized.
   941.       end if;
   942.
   943.       normalizer := nr_leading_zeros(frac.msw);
   944.
   945.       if normalizer > 38 then
   946.          normalizer := 39 + nr_leading_zeros(frac.lsw);
   947.       end if;
   948.
   949.       frac := scale_up(frac, normalizer);
   950.       KDF9_exponent := KDF9_exponent - KDF9.word(normalizer);
   951.       the_CPU_delta := the_CPU_delta + shift_time(normalizer);
   952.
   953.       -- 96-bit shift_arithmetic does not round and so cannot overflow here.
   954.       frac := scale_down(frac, 8);
   955.       frac.lsw := scale_down(frac.lsw, 8);
   956.       -- Clear both scaler fields.
   957.       frac.msw := frac.msw and mantissa_mask;
   958.       frac.lsw := frac.lsw and mantissa_mask;
   959.       if resign(KDF9_exponent) < 0 then
   960.          -- Deal with underflow.
   961.          frac := (0, 0);
   962.          return;
   963.       elsif KDF9_exponent > 255 then
   964.          -- Deal with overflow.
   965.          the_V_bit := 1;
   966.          KDF9_exponent := 255;
   967.       end if;
   968.       frac.msw := frac.msw or shift_word_left(KDF9_exponent and 8#377#, 39);
   969.       if KDF9_exponent < 39 then
   970.          frac.lsw := 0;
   971.       else
   972.          frac.lsw := frac.lsw or shift_word_left((KDF9_exponent-39) and 8#377#, 39);
   973.       end if;
   974.
   975.    end reconstruct;
   976.
   977.    function "-" (R : CPU.double)
   978.    return CPU.double is
   979.    begin
   980.       return CPU.double'(0, 0) - R;
   981.    end "-";
   982.
   983.    function "+" (L, R : CPU.double)
   984.    return CPU.double is
   985.       -- Scale fractions to prevent overflow; must adjust exponent accordingly.
   986.       L_exponent : constant KDF9.word := scaler(L);
   987.       R_exponent : constant KDF9.word := scaler(R);
   988.       L_fraction : KDF9.pair := scale_down(fraction_pair(L), 1);
   989.       R_fraction : KDF9.pair := scale_down(fraction_pair(R), 1);
   990.       exponent   : KDF9.word;
   991.       the_result : KDF9.pair;
   992.       aligner    : Natural;
   993.    begin
   994.       if resign(R_exponent) >= resign(L_exponent) then
   995.          aligner := Natural(resign(R_exponent-L_exponent));
   996.          aligner := Natural'Min(95, aligner);
   997.          L_fraction := scale_down(L_fraction, aligner);
   998.          exponent := R_exponent + 1;
   999.       else
  1000.          aligner := Natural(resign(L_exponent-R_exponent));
  1001.          aligner := Natural'Min(95, aligner);
  1002.          R_fraction := scale_down(R_fraction, aligner);
  1003.          exponent := L_exponent + 1;
  1004.       end if;
  1005.       the_CPU_delta := the_CPU_delta + shift_time(aligner);
  1006.       the_result := L_fraction + R_fraction;  -- "+" cannot overflow here.
  1007.       reconstruct(the_result, scaler => exponent);
  1008.       return as_double(the_result);
  1009.    end "+";
  1010.
  1011.    function "-" (L, R : CPU.double)
  1012.    return CPU.double is
  1013.       -- See "+".
  1014.       L_exponent : constant KDF9.word := scaler(L);
  1015.       R_exponent : constant KDF9.word := scaler(R);
  1016.       L_fraction : KDF9.pair := scale_down(fraction_pair(L), 1);
  1017.       R_fraction : KDF9.pair := scale_down(fraction_pair(R), 1);
  1018.       exponent   : KDF9.word;
  1019.       the_result : KDF9.pair;
  1020.       aligner    : Natural;
  1021.    begin
  1022.       if resign(R_exponent) >= resign(L_exponent) then
  1023.          aligner := Natural(resign(R_exponent-L_exponent));
  1024.          aligner := Natural'Min(95, aligner);
  1025.          L_fraction := scale_down(L_fraction, aligner);
  1026.          exponent := R_exponent + 1;
  1027.       else
  1028.          aligner := Natural(resign(L_exponent-R_exponent));
  1029.          aligner := Natural'Min(95, aligner);
  1030.          R_fraction := scale_down(R_fraction, aligner);
  1031.          exponent := L_exponent + 1;
  1032.       end if;
  1033.       the_CPU_delta := the_CPU_delta + shift_time(aligner);
  1034.       the_result := L_fraction - R_fraction;  -- "-" cannot overflow here.
  1035.       reconstruct(the_result, scaler => exponent);
  1036.       return as_double(the_result);
  1037.  end "-";
  1038.
  1039.    function "*" (L, R : CPU.float)
  1040.    return CPU.double is
  1041.       old_V_bit : constant KDF9.word := the_V_bit;
  1042.       LR        : KDF9.pair;
  1043.    begin
  1044.       the_V_bit := 0;
  1045.       LR := fraction_word(L) * fraction_word(R);
  1046.       if the_V_bit /= 0 then
  1047.          -- The product is not a valid fixed-point fraction, but is actually OK,
  1048.          --    so restore the orginal overflow state, and  ...
  1049.          the_V_bit := old_V_bit;
  1050.          --  ... construct +1.0 in double-precision floating-point.
  1051.          return as_double((shift_word_left(2#0_10_000_001_1#, 38), 0));
  1052.       end if;
  1053.       reconstruct(LR, scaler => scaler(L) + scaler(R));
  1054.       return as_double(LR);
  1055.    end "*";
  1056.
  1057.    function "/" (L : CPU.double;
  1058.                  R : CPU.float)
  1059.    return CPU.float is  -- aka DIVDF
  1060.       -- If L>=R, L/R>= 1, which is not a valid fraction; so Ls and Rs are
  1061.       --    scaled so that the division cannot overflow.
  1062.       Ls     : constant KDF9.pair := scale_down(fraction_pair(L), 3);
  1063.       Rs     : constant KDF9.word := scale_down(fraction_word(R), 1);
  1064.       -- E is increased by 2 to compensate the quotient's scaling by 1/4.
  1065.       E      : constant KDF9.word := scaler(L) - scaler(R) + 2;
  1066.       F      : KDF9.word;
  1067.    begin
  1068.       if R = 0 then
  1069.          the_V_bit := 1;
  1070.          return L.msw;  -- ?? This result is not well defined in the Manual.
  1071.       end if;
  1072.       do_DIVD(Ls, Rs, F);  -- Division cannot overflow here.
  1073.       return normalized(full_fraction => F, scaler => E);
  1074.    end "/";
  1075.
  1076.    function host_double (X : CPU.double)
  1077.    return Long_Float is
  1078.       W : constant KDF9.pair  := fraction_pair(X);
  1079.       S : constant Long_Float := 2.0**Integer(resign(scaler(X)));
  1080.    begin
  1081.       return Long_Float(fractional(W.msw)) * S;
  1082.    end host_double;
  1083.
  1084.    function KDF9_double (X : Long_Float)
  1085.    return CPU.double is
  1086.       U : constant CPU.u_64 := as_u_64(X);
  1087.       E : KDF9.word;
  1088.       F : KDF9.pair;
  1089.    begin
  1090.       if U = 0 then
  1091.          return (0, 0);
  1092.       end if;
  1093.       E := KDF9.word(Long_Float'Exponent(X));
  1094.       F.msw := KDF9.word(shift_right(shift_left(U, 11) or 2**63, 17));
  1095.       if resign(U) < 0 then
  1096.          F.msw := -F.msw;
  1097.       end if;
  1098.       F.lsw := 0;
  1099.       reconstruct(F, scaler => E);
  1100.       if the_V_bit /= 0 then
  1101.          raise Constraint_Error;
  1102.       end if;
  1103.       return as_double(F);
  1104.    end KDF9_double;
  1105.
  1106.    procedure push (F : in CPU.float) is
  1107.    begin
  1108.       push(KDF9.word(F));
  1109.    end push;
  1110.
  1111.    function pop
  1112.    return CPU.float is
  1113.    begin
  1114.       return CPU.float(KDF9.word'(pop));
  1115.    end pop;
  1116.
  1117.    function read_top
  1118.    return CPU.float is
  1119.    begin
  1120.       return CPU.float(KDF9.word'(read_top));
  1121.    end read_top;
  1122.
  1123.    procedure write_top (F : in CPU.float) is
  1124.    begin
  1125.       write_top(KDF9.word(F));
  1126.    end write_top;
  1127.
  1128.    procedure push (DF : in CPU.double) is
  1129.       AB : constant KDF9.pair := as_pair(DF);
  1130.    begin
  1131.       push(AB);
  1132.    end push;
  1133.
  1134.    function pop
  1135.    return CPU.double is
  1136.       AB : constant KDF9.pair := pop;
  1137.    begin
  1138.       return as_double(AB);
  1139.    end pop;
  1140.
  1141.    function read_top
  1142.    return CPU.double is
  1143.       AB : constant KDF9.pair := read_top;
  1144.    begin
  1145.       return as_double(AB);
  1146.    end read_top;
  1147.
  1148.    procedure write_top (DF : in CPU.double) is
  1149.       AB : constant KDF9.pair := as_pair(DF);
  1150.    begin
  1151.       write_top(AB);
  1152.    end write_top;
  1153.
  1154. end KDF9.CPU;

Compiling: ../Source\kdf9-cpu.ads
Source file time stamp: 2015-06-18 00:56:12
Compiled at: 2015-10-28 18:14:37

     1. -- kdf9-cpu.ads
     2. --
     3. -- Support for KDF9 CPU/ALU operations that are not automatically inherited from
     4. --   Ada types; and for types used in the internal functioning of the microcode.
     5. --
     6. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     7. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     8. --
     9. -- The ee9 program is free software; you can redistribute it and/or
    10. -- modify it under terms of the GNU General Public License as published
    11. -- by the Free Software Foundation; either version 3, or (at your option)
    12. -- any later version. This program is distributed in the hope that it
    13. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    14. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    15. -- See the GNU General Public License for more details. You should have
    16. -- received a copy of the GNU General Public License distributed with
    17. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    18. --
    19.
    20. with Ada.Unchecked_Conversion;
    21.
    22. package KDF9.CPU is
    23.
    24.    --
    25.    -- 48-bit integer and fractional ALU
    26.    --
    27.
    28.    type signed is range -2**47 .. +2**47 - 1;
    29.    for  signed'Size use KDF9.word'Size;
    30.
    31.    function unsign is new Ada.Unchecked_Conversion (CPU.signed, KDF9.word);
    32.
    33.    function resign is new Ada.Unchecked_Conversion (KDF9.word, CPU.signed);
    34.
    35.    function "-" (I : CPU.signed)
    36.    return KDF9.word;
    37.    pragma Inline("-");
    38.
    39.    function "abs" (I : CPU.signed)
    40.    return KDF9.word;
    41.    pragma Inline("abs");
    42.
    43.    function "+" (L, R : CPU.signed)
    44.    return KDF9.word;
    45.    pragma Inline("+");
    46.
    47.    function "-" (L, R : CPU.signed)
    48.    return KDF9.word;
    49.    pragma Inline("-");
    50.
    51.    function "*" (L, R : CPU.signed)
    52.    return KDF9.word;
    53.
    54.    -- Determine the Quotient and Remainder of L/R, where:
    55.    --    sign(Remainder) = sign(R) and |Remainder| < |R|, i.e. Remainder = L mod R;
    56.    --    Quotient = (L - Remainder) / R.
    57.    procedure do_DIVI (L : in KDF9.word;
    58.                       R : in KDF9.word;
    59.                       Quotient, Remainder : out KDF9.word);
    60.
    61.    -- Signed single-length integer division is removed from consideration.
    62.    function "/" (L, R : CPU.signed)
    63.    return KDF9.word is abstract;
    64.
    65.    function "mod" (L, R : CPU.signed)
    66.    return KDF9.word is abstract;
    67.
    68.    -- Contract a double-word, setting the V bit if necessary.
    69.    function contracted (P : KDF9.pair)
    70.    return KDF9.word;
    71.    pragma Inline(contracted);
    72.
    73.    -- Contract a double-word, represented by its components, setting the V bit if necessary.
    74.    function contracted (msw, lsw : KDF9.word)
    75.    return KDF9.word;
    76.    pragma Inline(contracted);
    77.
    78.    -- KDF9-semantics shifting operations.
    79.
    80.    type signed_Q_part is range  -2**15 .. +2**15 - 1;
    81.    for  signed_Q_part'Size use KDF9.Q_part'Size;
    82.
    83.    function resign is new Ada.Unchecked_Conversion (KDF9.Q_part, CPU.signed_Q_part);
    84.
    85.    -- L>0 for left-shift, L<0 for right two_shift.
    86.
    87.    function shift_logical (W : KDF9.word; L : CPU.signed_Q_part)
    88.    return KDF9.word;
    89.    pragma Inline(shift_logical);
    90.
    91.    function shift_circular (W : KDF9.word; L : CPU.signed_Q_part)
    92.    return KDF9.word;
    93.    pragma Inline(shift_circular);
    94.
    95.    -- shift_arithmetic rounds the result correctly.
    96.    function shift_arithmetic (I : KDF9.word; L : CPU.signed_Q_part)
    97.    return KDF9.word;
    98.    pragma Inline(shift_arithmetic);
    99.
   100.    -- cardinality yields the number of 1-bits in W.
   101.    function cardinality (W : KDF9.word)
   102.    return KDF9.word;
   103.    pragma Inline(cardinality);
   104.
   105.    -- A fraction is a word W interpreted as the value W / 2**47;
   106.
   107.    KDF9_small : constant := 2.0**(-47);
   108.    type fraction is delta KDF9_small range -1.0 .. +1.0 - KDF9_small;
   109.    for fraction'Size use KDF9.word'Size;
   110.
   111.    function fractional is new Ada.Unchecked_Conversion (KDF9.word, CPU.fraction);
   112.
   113.    function integral is new Ada.Unchecked_Conversion (CPU.fraction, KDF9.word);
   114.
   115.    -- These operations treat the KDF9.word operands as full-word fractions,
   116.
   117.    function "*" (L, R : KDF9.word)
   118.    return CPU.fraction;
   119.
   120.    function "/" (L, R : KDF9.word)
   121.    return CPU.fraction;
   122.
   123.
   124.    --
   125.    -- double-word (95- and 96-bit) ALU
   126.    --
   127.
   128.    function "+" (L, R : KDF9.pair)
   129.    return KDF9.pair;
   130.    pragma Inline("+");
   131.
   132.    function "-" (J : KDF9.pair)
   133.    return KDF9.pair;
   134.    pragma Inline("-");
   135.
   136.    function "-" (L, R : KDF9.pair)
   137.    return KDF9.pair;
   138.    pragma Inline("-");
   139.
   140.    -- 48 * 48 -> 96-bit, for XD, etc.
   141.    function "*" (L, R : KDF9.word)
   142.    return KDF9.pair;
   143.
   144.    -- 96 / 48 -> 48-bit, for DIVD, DIVR and DIVDF.
   145.    procedure do_DIVD (L : in KDF9.pair;
   146.                       R : in KDF9.word;
   147.                       Q : out KDF9.word;
   148.                       round : in Boolean := True
   149.                      );
   150.
   151.    procedure do_DIVR (L : in KDF9.pair;
   152.                       R : in KDF9.word;
   153.                       Quotient, Remainder : out KDF9.word
   154.                      );
   155.
   156.    function shift_logical (P : KDF9.pair; L : CPU.signed_Q_part)
   157.    return KDF9.pair;
   158.    pragma Inline(shift_logical);
   159.
   160.    function shift_arithmetic (P : KDF9.pair; L : CPU.signed_Q_part)
   161.    return KDF9.pair;
   162.    pragma Inline(shift_arithmetic);
   163.
   164.
   165.    --
   166.    -- 48-bit floating point ALU
   167.    --
   168.
   169.    type float is mod 2**48;  -- This is a substrate for KDF9 f.p., not an Ada f.p. type.
                |
        >>> warning: redefinition of entity "float" in Standard

   170.    for  float'Size use KDF9.word'Size;
   171.
   172.    -- Remove useless substrate modular operations.
   173.
   174.    overriding
   175.    function "not" (R : CPU.float)
   176.    return CPU.float is abstract;
   177.
   178.    overriding
   179.    function "and" (L, R : CPU.float)
   180.    return CPU.float is abstract;
   181.
   182.    overriding
   183.    function "or" (L, R : CPU.float)
   184.    return CPU.float is abstract;
   185.
   186.    overriding
   187.    function "xor" (L, R : CPU.float)
   188.    return CPU.float is abstract;
   189.
   190.    overriding
   191.    function "mod" (L, R : CPU.float)
   192.    return CPU.float is abstract;
   193.
   194.    function as_word is new Ada.Unchecked_Conversion (CPU.float, KDF9.word);
   195.
   196.    function as_float is new Ada.Unchecked_Conversion (KDF9.word, CPU.float);
   197.
   198.    procedure push (F : in CPU.float);
   199.    pragma Inline(push);
   200.
   201.    function pop
   202.    return CPU.float;
   203.    pragma Inline(pop);
   204.
   205.    procedure write_top (F : in CPU.float);
   206.    pragma Inline(write_top);
   207.
   208.    function read_top
   209.    return CPU.float;
   210.    pragma Inline(read_top);
   211.
   212.     -- Standardize a (possibly) non-normalized floating-point number.
   213.    function normalized  (R : CPU.float)
   214.    return CPU.float;
   215.
   216.    -- Convert a 47-bit fraction to a rounded, standardized 39-bit mantissa,
   217.    --    and adjust its exponent accordingly.
   218.    procedure normalize (fraction, exponent : in out KDF9.word);
   219.    pragma Inline(normalize);
   220.
   221.    -- Convert a 39-bit mantissa to a 47-bit fraction, preserving the sign.
   222.    function fraction_word (mantissa : CPU.float)
   223.    return KDF9.word;
   224.    pragma Inline(fraction_word);
   225.
   226.    -- The floating-point number with the exponent field set to 0.
   227.    function masked_mantissa (F : CPU.float)
   228.    return CPU.float;
   229.    pragma Inline(masked_mantissa);
   230.
   231.    -- The algebraic scale-factor,  not the hardware exponent, -128 <= scaler < +128.
   232.    function scaler (F : CPU.float)
   233.    return KDF9.word;
   234.    pragma Inline(scaler);
   235.
   236.     -- Synthesize a normalized floating-point number from its components.
   237.    function normalized (full_fraction, scaler : KDF9.word)
   238.    return CPU.float;
   239.    pragma Inline(normalized);
   240.
   241.    -- Round a 48-bit floating-point number to 24-bit format.
   242.    function rounded (R : CPU.float)
   243.    return CPU.float;
   244.
   245.    overriding
   246.    function "-" (R : CPU.float)
   247.    return CPU.float;
   248.
   249.    overriding
   250.    function "abs" (R : CPU.float)
   251.    return CPU.float;
   252.
   253.    overriding
   254.    function "+" (L, R : CPU.float)
   255.    return CPU.float;
   256.
   257.    overriding
   258.    function "-" (L, R : CPU.float)
   259.    return CPU.float;
   260.
   261.    overriding
   262.    function "*" (L, R : CPU.float)
   263.    return CPU.float;
   264.
   265.    overriding
   266.    function "/" (L, R : CPU.float)
   267.    return CPU.float;
   268.
   269.    overriding
   270.    function "<" (L, R : CPU.float)
   271.    return Boolean;
   272.
   273.    function host_float (X : CPU.float)
   274.    return Long_Float;
   275.
   276.    function KDF9_float (X : Long_Float)
   277.    return CPU.float;
   278.
   279.    exponent_mask : constant KDF9.word := KDF9.word'(2#11_111_111#) * 2**39;
   280.    mantissa_mask : constant KDF9.word := not exponent_mask;
   281.    frac_msb_mask : constant KDF9.word := 2**46;  -- M.S.B. of a 47-bit fraction
   282.    mant_msb_mask : constant KDF9.word := 2**38;  -- M.S.B. of a 39-bit mantissa
   283.    overflow_mask : constant KDF9.word := 2**39;  -- bit set on rounding overflow
   284.
   285.
   286.    --
   287.    -- 96-bit floating point ALU
   288.    --
   289.
   290.    type double is
   291.       record
   292.          msw, lsw : CPU.float;
   293.       end record;
   294.
   295.    function as_pair is new Ada.Unchecked_Conversion (CPU.double, KDF9.pair);
   296.
   297.    function as_double is new Ada.Unchecked_Conversion (KDF9.pair, CPU.double);
   298.
   299.    procedure push (DF : in CPU.double);
   300.    pragma Inline(push);
   301.
   302.    function pop
   303.    return CPU.double;
   304.    pragma Inline(pop);
   305.
   306.    procedure write_top (DF : in CPU.double);
   307.    pragma Inline(write_top);
   308.
   309.    function read_top
   310.    return CPU.double;
   311.    pragma Inline(read_top);
   312.
   313.    -- The algebraic scale-factor,  not the hardware exponent, -128 <= scaler < +128.
   314.    function scaler (DF : CPU.double)
   315.    return KDF9.word;
   316.    pragma Inline(scaler);
   317.
   318.    -- Round a 96-bit double-precision floating-point number to 48 bit format.
   319.    function rounded (DF : CPU.double)
   320.    return CPU.float;
   321.    pragma Inline(rounded);
   322.
   323.    -- Derive a 96-bit fraction from the double-precision floating-point number,
   324.    --    with the mantissa bits in D9-D47 and D49-D87,
   325.    --       and with D1-D8 copies of the sign, D48 zero, and D87-D95 zero.
   326.    function fraction_pair (DF : CPU.double)
   327.    return KDF9.pair;
   328.    pragma Inline(fraction_pair);
   329.
   330.    -- Convert 96-bit fraction, and an algebraic scale-factor exponent,
   331.    --    into a 96-bit floating point number, setting overflow when necessary.
   332.    procedure reconstruct (frac   : in out KDF9.pair;
   333.                           scaler : in KDF9.word);
   334.
   335.    function "-" (R : CPU.double)
   336.    return CPU.double;
   337.
   338.    function "+" (L, R : CPU.double)
   339.    return CPU.double;
   340.
   341.    function "-" (L, R : CPU.double)
   342.    return CPU.double;
   343.
   344.    function "*" (L, R : CPU.float)
   345.    return CPU.double;
   346.
   347.    function "/" (L : CPU.double;
   348.                  R : CPU.float)
   349.    return CPU.float;
   350.
   351.    function host_double (X : CPU.double)
   352.    return Long_Float;
   353.
   354.    function KDF9_double (X : Long_Float)
   355.    return CPU.double;
   356.
   357.
   358.    --
   359.    -- These are the emulation host's register types and their operations.
   360.    --
   361.
   362.    type u_64 is mod 2**64;
   363.    for  u_64'Size use 64;
   364.
   365.    function as_word (u : CPU.u_64)
   366.    return KDF9.word;
   367.    pragma Inline(as_word);
   368.
   369.    function rotate_right (u : CPU.u_64; amount : Natural)
   370.    return CPU.u_64;
   371.
   372.    function shift_right (u : CPU.u_64; amount : Natural)
   373.    return CPU.u_64;
   374.
   375.    function shift_right_arithmetic (u : CPU.u_64; amount : Natural)
   376.    return CPU.u_64;
   377.
   378.    function rotate_left (u : CPU.u_64; amount : Natural)
   379.    return CPU.u_64;
   380.
   381.    function shift_left (u : CPU.u_64; amount : Natural)
   382.    return CPU.u_64;
   383.
   384.    pragma Import(Intrinsic, rotate_left);
   385.    pragma Import(Intrinsic, rotate_right);
   386.    pragma Import(Intrinsic, shift_left);
   387.    pragma Import(Intrinsic, shift_right);
   388.    pragma Import(Intrinsic, shift_right_arithmetic);
   389.
   390.    type s_64 is range -2**63 .. +2**63-1;
   391.    for  s_64'Size use CPU.u_64'Size;
   392.
   393.    -- The signed as_word sets the V bit if necessary.
   394.    function as_word (s : CPU.s_64)
   395.    return KDF9.word;
   396.    pragma Inline(as_word);
   397.
   398.    function unsign is new Ada.Unchecked_Conversion(CPU.s_64, CPU.u_64);
   399.
   400.    function resign is new Ada.Unchecked_Conversion(CPU.u_64, CPU.s_64);
   401.
   402.
   403.    --
   404.    -- These are KDF9's 48-bit primitive, fixed-direction, shift operations.
   405.    --
   406.
   407.    function shift_time (amount : Natural)
   408.    return KDF9.microseconds;
   409.    pragma Inline(shift_time);
   410.
   411.    subtype word_shift_length is Natural range 0..48;
   412.
   413.    function shift_word_left (W : KDF9.word; amount : word_shift_length)
   414.    return KDF9.word;
   415.    pragma Inline(shift_word_left);
   416.
   417.    function shift_word_right (W : KDF9.word; amount : word_shift_length)
   418.    return KDF9.word;
   419.    pragma Inline(shift_word_right);
   420.
   421.    function rotate_word_left (W : KDF9.word; amount : word_shift_length)
   422.    return KDF9.word;
   423.    pragma Inline(rotate_word_left);
   424.
   425.    function rotate_word_right (W : KDF9.word; amount : word_shift_length)
   426.    return KDF9.word;
   427.    pragma Inline(rotate_word_right);
   428.
   429.    -- scale_up may set the V bit.
   430.    function scale_up (W : KDF9.word; amount : Natural)
   431.    return KDF9.word;
   432.    pragma Inline(scale_up);
   433.
   434.    -- scale_down_and_round rounds correctly.
   435.    function scale_down_and_round (W : KDF9.word; amount : Natural)
   436.    return KDF9.word;
   437.    pragma Inline(scale_down_and_round);
   438.
   439.    -- scale_down never rounds.
   440.    function scale_down (W : KDF9.word; amount : Natural)
   441.    return KDF9.word;
   442.    pragma Inline(scale_down);
   443.
   444. end KDF9.CPU;


GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\kdf9-phu_store.adb
Source file time stamp: 2015-06-18 00:56:06
Compiled at: 2015-10-28 18:14:43

     1. -- kdf9-PHU_store.adb
     2. --
     3. -- The K5 operation data formats.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Unchecked_Conversion;
    20.
    21. with KDF9.CPU;
    22.
    23. package body KDF9.PHU_store is
    24.
    25.    pragma Unsuppress(All_Checks);
    26.
    27.    function short_PHU (p : KDF9.priority)
    28.    return KDF9.word is
    29.
    30.       type PHU_as_6_bits is mod 2**6;
    31.       for  PHU_as_6_bits'Size use 6;
    32.
    33.       function as_6_bits is new Unchecked_Conversion(Source => PHU_store.PHU_subset,
    34.                                                      Target => short_PHU.PHU_as_6_bits);
    35.
    36.       the_reason    : PHU_store.blockage_kind;
    37.       the_parameter : KDF9.buffer_number;
    38.
    39.    begin
    40.       if not PHU(p).is_held_up then
    41.          return 0;  -- All fields are non-significant.
    42.       end if;
    43.
    44.       -- PHU(p).is_held_up, so other fields are valid.
    45.       the_reason := PHU(p).blockage.reason;
    46.       if the_reason = buffer_busy then
    47.          the_parameter := PHU(p).blockage.buffer_nr;
    48.       else
    49.          -- This is next to useless, but is what the K5 order actually did.
    50.          the_parameter := KDF9.buffer_number(PHU(p).blockage.group_nr mod 2**4);
    51.       end if;
    52.
    53.       return KDF9.word(as_6_bits((True, the_reason, the_parameter)));
    54.    end short_PHU;
    55.
    56.    function K5_operand
    57.    return KDF9.word is
    58.    begin
    59.       return
    60.           KDF9.CPU.shift_word_left(short_PHU(0), 47-05) or
    61.           KDF9.CPU.shift_word_left(short_PHU(1), 47-11) or
    62.           KDF9.CPU.shift_word_left(short_PHU(2), 47-17) or
    63.           KDF9.CPU.shift_word_left(short_PHU(3), 47-23);
    64.    end K5_operand;
    65.
    66. end KDF9.PHU_store;

Compiling: ../Source\kdf9-phu_store.ads
Source file time stamp: 2015-06-18 00:56:06
Compiled at: 2015-10-28 18:14:43

     1. -- kdf9-PHU_store.ads
     2. --
     3. -- The K5 operation data formats.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package KDF9.PHU_store is
    20.
    21.    -- PHU, the Program Hold-Up register is internal to I/O Control.
    22.    -- It has one element for each of the 4 program priority levels, 0..3.
    23.    -- A subset of its content is exposed to Director by means of the K5 order.
    24.
    25.    type blockage_kind is (buffer_busy, locked_out);
    26.    for  blockage_kind'Size use 1;
    27.
    28.    type group_address is mod 1024;
    29.    for  group_address'Size use 10;
    30.
    31.    type PHU_reason (reason : PHU_store.blockage_kind := buffer_busy) is
    32.       record
    33.          case reason is
    34.             when buffer_busy =>
    35.                buffer_nr  : KDF9.buffer_number;
    36.                INTQq_wait : KDF9.one_bit;
    37.             when locked_out =>
    38.                group_nr   : PHU_store.group_address;
    39.          end case;
    40.       end record;
    41.
    42.    type PHU_register (is_held_up : Boolean := False) is
    43.       record
    44.          case is_held_up is
    45.             when False =>
    46.                null;
    47.             when True =>
    48.                blockage : PHU_reason;
    49.          end case;
    50.       end record;
    51.
    52.    idle_PHU : constant PHU_register := (is_held_up => False);
    53.
    54.    PHU : array (KDF9.priority) of PHU_store.PHU_register := (others => idle_PHU);
    55.
    56.    type PHU_subset is
    57.       record
    58.          is_held_up : Boolean;
    59.          reason     : PHU_store.blockage_kind;
    60.          parameter  : KDF9.buffer_number;
    61.       end record;
    62.    for PHU_subset'Size use 6;
    63.    for PHU_subset'Bit_Order use Low_Order_First;
    64.
    65.    for  PHU_subset use
    66.       record
    67.          is_held_up at 0 range 5 .. 5;
    68.          reason     at 0 range 4 .. 4;
    69.          parameter  at 0 range 0 .. 3;
    70.       end record;
    71.
    72.    -- A K5_operand is a KDF9 word, D00-D47, with the content:
    73.    --    PHU_subset(0) in D00 .. D05
    74.    --    PHU_subset(1) in D06 .. D11
    75.    --    PHU_subset(2) in D12 .. D17
    76.    --    PHU_subset(3) in D18 .. D23
    77.    --    zeros         in D24 .. D47
    78.
    79.    function K5_operand
    80.    return KDF9.word;
    81.
    82. end KDF9.PHU_store;

 66 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\io.adb
Source file time stamp: 2015-06-18 00:56:40
Compiled at: 2015-10-28 18:14:44

     1. -- io.adb
     2. --
     3. -- Buffered I/O.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Latin_1;
    20. with OS_specifics;
    21.
    22. use  Latin_1;
    23. use  OS_specifics;
    24.
    25. package body IO is
    26.
    27.    pragma Unsuppress(All_Checks);
    28.
    29.    function fd_of (the_stream : IO.stream)
    30.    return Natural is
    31.    begin
    32.       return the_stream.fd;
    33.    end fd_of;
    34.
    35.    function image_of (the_stream : IO.stream;
    36.                       caption    : String := "")
    37.    return String is
    38.    begin
    39.       if the_stream.is_open then
    40.          return caption
    41.               & ": "
    42.               & "base_name = "
    43.               & the_stream.base_name
    44.               & EOL
    45.               & "block_size ="
    46.               & Natural'Image(the_stream.block_size)
    47.               & EOL
    48.               & "bytes_moved ="
    49.               & KDF9.word'Image(the_stream.bytes_moved)
    50.               & EOL
    51.               & "fd ="
    52.               & Natural'Image(the_stream.fd)
    53.               & EOL
    54.               & "IO_mode ="
    55.               & POSIX.access_mode'Image(the_stream.IO_mode)
    56.               & EOL
    57.               & "last_IO ="
    58.               & POSIX.access_mode'Image(the_stream.last_IO)
    59.               & EOL
    60.               & "next_byte ="
    61.               & Natural'Image(the_stream.next_byte)
    62.               & EOL
    63.               & "position ="
    64.               & Natural'Image(the_stream.position)
    65.               & EOL
    66.               & "column = "
    67.               & Natural'Image(the_stream.column);
    68.       else
    69.          return caption;
    70.       end if;
    71.    end image_of;
    72.
    73.    procedure diagnose (the_stream : IO.stream;
    74.                        caption    : String := "") is
    75.    begin
    76.       put_error_message(image_of(the_stream, caption));
    77.    end diagnose;
    78.
    79.    procedure open (the_stream : in out IO.stream;
    80.                    file_name  : in String;
    81.                    mode       : in POSIX.access_mode;
    82.                    fd         : in Integer) is
    83.    begin
    84.       if fd >= 0 then
    85.          make_transparent(fd);
    86.          the_stream.base_name := file_name(file_name'First .. file_name'First+2);
    87.          the_stream.IO_mode := mode;
    88.          the_stream.last_IO := read_mode;
    89.          the_stream.fd := fd;
    90.          the_stream.is_open := True;
    91.       else
    92.          diagnose(the_stream, "'" & file_name & "'");
    93.       end if;
    94.    end open;
    95.
    96.    procedure open (the_stream : in out IO.stream;
    97.                    file_name  : in String;
    98.                    mode       : in POSIX.access_mode) is
    99.    begin
   100.       open(the_stream, file_name, mode, open(file_name, mode));
   101.    exception
   102.       when others =>
   103.          if file_name /= "FW0" then
   104.             diagnose(the_stream, "'" & file_name & "'");
   105.          end if;
   106.    end open;
   107.
   108.    procedure truncate (the_stream : in out IO.stream;
   109.                        to_length  : in KDF9.word := 0) is
   110.    begin
   111.       truncate(the_stream.fd, POSIX.file_position(to_length));
   112.    end truncate;
   113.
   114.    procedure close (the_stream : in out IO.stream) is
   115.       response : Integer;
   116.       pragma Unreferenced(response);
   117.    begin
   118.       if the_stream.is_open then
   119.          flush(the_stream);
   120.          response := close(the_stream.fd);
   121.          the_stream.is_open := False;
   122.       end if;
   123.    end close;
   124.
   125.    procedure flush (the_stream  : in out IO.stream;
   126.                     a_byte_time : in KDF9.microseconds := 0) is
   127.       response : Integer;
   128.       pragma Unreferenced(response);
   129.    begin
   130.       if the_stream.is_open      and then
   131.             the_stream.next_byte > 0 then
   132.          if the_stream.IO_mode > read_mode and the_stream.last_IO = write_mode then
   133.             if a_byte_time = 0 then
   134.                response := write(the_stream.fd, the_stream.buffer, the_stream.next_byte);
   135.             else
   136.                for b in 1 .. the_stream.next_byte loop
   137.                   response := write(the_stream.fd, the_stream.buffer(b..b), 1);
   138.                   KDF9.delay_by(a_byte_time);
   139.                end loop;
   140.             end if;
   141.          end if;
   142.          the_stream.next_byte := 0;
   143.          the_stream.block_size := 0;
   144.       end if;
   145.    exception
   146.       when POSIX_IO_error =>
   147.          diagnose(the_stream, "FLUSH POSIX_IO_error");
   148.          raise stream_IO_error;
   149.    end flush;
   150.
   151.    function a_LF_was_just_read (the_stream : IO.stream)
   152.    return Boolean is
   153.    begin
   154.       if the_stream.is_open               and then
   155.             the_stream.bytes_moved > 0    and then
   156.                the_stream.last_IO = read_mode then
   157.          return (the_stream.next_byte = 0 and the_stream.block_size = 0);
   158.       else
   159.          return False;
   160.       end if;
   161.    end a_LF_was_just_read;
   162.
   163.    function a_LF_was_just_written (the_stream : IO.stream)
   164.    return Boolean is
   165.    begin
   166.       if the_stream.is_open                and then
   167.             the_stream.bytes_moved > 0     and then
   168.                the_stream.last_IO /= read_mode then
   169.          return the_stream.column = 0;
   170.       else
   171.          return False;
   172.       end if;
   173.    end a_LF_was_just_written;
   174.
   175.    procedure reattach (the_stream : in out IO.stream;
   176.                        file_name  : in String;
   177.                        mode       : in POSIX.access_mode) is
   178.       old_fd : constant Natural := the_stream.fd;
   179.    begin
   180.       close(the_stream);
   181.       if mode /= the_stream.IO_mode then
   182.          diagnose(the_stream, "REATTACH: the new mode is incompatible");
   183.          raise stream_IO_error;
   184.       end if;
   185.       open(the_stream, file_name, mode);
   186.       if old_fd = 0 and the_stream.fd /= 0 then
   187.          diagnose(the_stream, "REATTACH standard input: the new fd /= 0");
   188.          raise stream_IO_error;
   189.       end if;
   190.       the_stream.last_char := ' ';
   191.       the_stream.block_size := 0;
   192.       the_stream.next_byte := 0;
   193.       the_stream.position := 0;
   194.    exception
   195.       when others =>
   196.          diagnose(the_stream, "REATTACH error");
   197.          raise stream_IO_error;
   198.    end reattach;
   199.
   200.    function is_open(the_stream : IO.stream)
   201.    return Boolean is
   202.    begin
   203.       return the_stream.is_open;
   204.    end is_open;
   205.
   206.    function bytes_moved(the_stream : IO.stream)
   207.    return KDF9.word is
   208.    begin
   209.       return the_stream.bytes_moved;
   210.    end bytes_moved;
   211.
   212.    function file_size (the_stream : IO.stream)
   213.    return Natural is
   214.       first : constant POSIX.file_position := seek(the_stream.fd, 0, from_here);
   215.       size  : constant POSIX.file_position := seek(the_stream.fd, 0, from_end);
   216.       last  : constant POSIX.file_position := seek(the_stream.fd, first, from_start);
   217.    begin
   218.       if first /= last then
   219.          raise end_of_stream;
   220.       end if;
   221.       return Natural(size);
   222.    end file_size;
   223.
   224.    function column (the_stream : IO.stream)
   225.    return Natural is
   226.    begin
   227.       return the_stream.column;
   228.    end column;
   229.
   230.    procedure get_position (position   : out Natural;
   231.                            the_stream : in out IO.stream) is
   232.    begin
   233.       flush(the_stream);
   234.       position := the_stream.position;
   235.    end get_position;
   236.
   237.    function buffer_is_empty (the_stream : IO.stream)
   238.    return Boolean is
   239.    begin
   240.       return not the_stream.is_open or else
   241.                (the_stream.next_byte = the_stream.block_size);
   242.    end buffer_is_empty;
   243.
   244.    function buffer_is_full (the_stream : IO.stream)
   245.    return Boolean is
   246.    begin
   247.       return the_stream.is_open and then
   248.                 the_stream.next_byte = the_stream.buffer'Last;
   249.    end buffer_is_full;
   250.
   251.    procedure set_position (position   : in Natural;
   252.                            the_stream : in out IO.stream;
   253.                            whence     : in POSIX.seek_origin := from_start) is
   254.       response : POSIX.file_position;
   255.       pragma Unreferenced(response);
   256.    begin
   257.       flush(the_stream);
   258.       response := seek(the_stream.fd, POSIX.file_position(position), whence);
   259.       the_stream.position := position;
   260.    exception
   261.       when POSIX_IO_error =>
   262.          diagnose(the_stream, "set_position POSIX_IO_error");
   263.          raise;
   264.    end set_position;
   265.
   266.    procedure reset (the_stream : in out IO.stream) is
   267.    begin
   268.       flush(the_stream);
   269.       if the_stream.is_open then
   270.          the_stream.last_IO := read_mode;
   271.          the_stream.position := 0;
   272.          the_stream.next_byte := 0;
   273.          the_stream.block_size := 0;
   274.       end if;
   275.    end reset;
   276.
   277.    procedure back_off (the_stream : in out IO.stream) is
   278.    begin
   279.       if the_stream.is_open                and then
   280.             the_stream.next_byte > 0       and then
   281.                the_stream.last_IO = read_mode  then
   282.          the_stream.next_byte := the_stream.next_byte - 1;
   283.          the_stream.position := the_stream.position - 1;
   284.       else
   285.          raise stream_IO_error;
   286.       end if;
   287.    end back_off;
   288.
   289.    procedure get_byte (char       : out Character;
   290.                        the_stream : in out IO.stream) is
   291.       response : Integer;
   292.    begin
   293.       if not the_stream.is_open then
   294.          raise end_of_stream;
   295.       end if;
   296.       if buffer_is_empty(the_stream) then
   297.          response := read(the_stream.fd,
   298.                           the_stream.buffer,
   299.                           the_stream.buffer'Size);
   300.          if response <= 0 then
   301.             raise end_of_stream;
   302.          end if;
   303.          the_stream.block_size := response;
   304.          the_stream.next_byte := 0;
   305.       end if;
   306.       the_stream.next_byte := the_stream.next_byte + 1;
   307.       the_stream.position := the_stream.position + 1;
   308.       the_stream.bytes_moved := the_stream.bytes_moved + 1;
   309.       the_stream.last_IO := read_mode;
   310.       char := the_stream.buffer(the_stream.next_byte);
   311.       if char = LF then
   312.          the_stream.column := 0;
   313.       else
   314.          the_stream.column := the_stream.column + 1;
   315.       end if;
   316.    exception
   317.       when end_of_stream =>
   318.          raise;
   319.       when POSIX_IO_error =>
   320.          diagnose(the_stream, "GET_BYTE POSIX_IO_error");
   321.          raise end_of_stream;
   322.       when others =>
   323.          diagnose(the_stream, "GET_BYTE error");
   324.          raise stream_IO_error;
   325.    end get_byte;
   326.
   327.    procedure get_bytes (the_string : out String;
   328.                         the_stream : in out IO.stream;
   329.                         uncounted  : in Boolean := True) is
   330.       old_bytes_moved : constant KDF9.word := the_stream.bytes_moved;
   331.    begin
   332.       for i in the_string'Range loop
   333.          get_byte(the_string(i), the_stream);
   334.       end loop;
   335.       if uncounted then
   336.          the_stream.bytes_moved := old_bytes_moved;
   337.       end if;
   338.    end get_bytes;
   339.
   340.    procedure get_char (char       : out Character;
   341.                        the_stream : in out IO.stream) is
   342.    begin
   343.       get_byte(char, the_stream);
   344.       if char = CR then
   345.          char := LF;
   346.          the_stream.last_char := CR;
   347.       elsif char = LF and the_stream.last_char = CR then
   348.          the_stream.last_char := LF;
   349.          get_byte(char, the_stream);
   350.       else
   351.          the_stream.last_char := char;
   352.       end if;
   353.    end get_char;
   354.
   355.    procedure peek_at_char (char       : out Character;
   356.                            the_stream : in out IO.stream) is
   357.    begin
   358.       get_char(char, the_stream);
   359.       back_off(the_stream);
   360.    end peek_at_char;
   361.
   362.    procedure put_byte (char       : in Character;
   363.                        the_stream : in out IO.stream) is
   364.       response : Integer;
   365.    begin
   366.       if not the_stream.is_open then
   367.          raise end_of_stream;
   368.       end if;
   369.       if buffer_is_full(the_stream) then
   370.          response := write(the_stream.fd,
   371.                            the_stream.buffer,
   372.                            the_stream.buffer'Size);
   373.          if response <= 0 then
   374.             raise end_of_stream;
   375.          end if;
   376.          the_stream.next_byte := 0;
   377.       end if;
   378.       the_stream.next_byte := the_stream.next_byte + 1;
   379.       the_stream.position := the_stream.position + 1;
   380.       the_stream.bytes_moved := the_stream.bytes_moved + 1;
   381.       the_stream.buffer(the_stream.next_byte) := char;
   382.       the_stream.last_IO := write_mode;
   383.       if char = LF then
   384.          the_stream.column := 0;
   385.       else
   386.          the_stream.column := the_stream.column + 1;
   387.       end if;
   388.    exception
   389.       when end_of_stream =>
   390.          raise;
   391.       when POSIX_IO_error =>
   392.          diagnose(the_stream, "PUT_BYTE POSIX_IO_error");
   393.          raise end_of_stream;
   394.       when others =>
   395.          diagnose(the_stream, "PUT_BYTE error (POSIX_IO_error) ");
   396.          raise stream_IO_error;
   397.    end put_byte;
   398.
   399.    procedure put_bytes (the_string : in String;
   400.                         the_stream : in out IO.stream;
   401.                         uncounted  : in Boolean := True) is
   402.       old_bytes_moved : constant KDF9.word := the_stream.bytes_moved;
   403.    begin
   404.       for i in the_string'Range loop
   405.          put_byte(the_string(i), the_stream);
   406.       end loop;
   407.       if uncounted then
   408.          the_stream.bytes_moved := old_bytes_moved;
   409.       end if;
   410.    end put_bytes;
   411.
   412.    procedure put_EOL (the_stream : in out IO.stream) is
   413.    begin
   414.       put_bytes(EOL, the_stream);
   415.    end put_EOL;
   416.
   417.    procedure put_char (char       : in Character;
   418.                        the_stream : in out IO.stream) is
   419.    begin
   420.       if char = LF then
   421.          put_EOL(the_stream);
   422.       else
   423.          put_byte(char, the_stream);
   424.       end if;
   425.    end put_char;
   426.
   427.    procedure put_chars (the_string : in String;
   428.                         the_stream : in out IO.stream) is
   429.    begin
   430.       for i in the_string'Range loop
   431.          put_char(the_string(i), the_stream);
   432.       end loop;
   433.    end put_chars;
   434.
   435.    function contents (the_stream : IO.stream)
   436.    return String is
   437.    begin
   438.       if the_stream.is_open then
   439.          return the_stream.buffer(1 .. the_stream.next_byte);
   440.       else
   441.          return "";
   442.       end if;
   443.    end contents;
   444.
   445.    procedure inject (the_string : in String;
   446.                      the_stream : in out IO.stream) is
   447.    begin
   448.       if not the_stream.is_open then
   449.          diagnose(the_stream,
   450.                   "injecting '"
   451.                 & the_string
   452.                 & "' into  closed stream '"
   453.                 & the_stream.contents
   454.                 & "'"
   455.                 & EOL );
   456.          raise stream_IO_error;
   457.       end if;
   458.       the_stream.block_size := the_string'Length;
   459.       if the_stream.block_size > 0 then
   460.          the_stream.buffer(1 .. the_stream.block_size) := the_string;
   461.          the_stream.buffer(the_stream.block_size+1) := LF;
   462.       end if;
   463.    end inject;
   464.
   465. end IO;

Compiling: ../Source\io.ads
Source file time stamp: 2015-06-18 00:56:40
Compiled at: 2015-10-28 18:14:44

     1. -- io.ads
     2. --
     3. -- Buffered I/O.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9;
    20. with POSIX;
    21.
    22. use  KDF9;
    23. use  POSIX;
    24.
    25. package IO is
    26.
    27.    stream_IO_error, end_of_stream : exception;
    28.
    29.    type stream is tagged limited private;
    30.
    31.    function fd_of (the_stream : IO.stream)
    32.    return Natural;
    33.
    34.    function image_of (the_stream : IO.stream;
    35.                       caption    : String := "")
    36.    return String;
    37.
    38.    procedure diagnose (the_stream : IO.stream;
    39.                        caption    : String := "");
    40.
    41.    -- Open a stream with an established fd.
    42.    procedure open (the_stream : in out IO.stream;
    43.                    file_name  : in String;
    44.                    mode       : in POSIX.access_mode;
    45.                    fd         : in Integer);
    46.
    47.    -- Open a base file then use its fd to open a stream.
    48.    procedure open (the_stream : in out IO.stream;
    49.                    file_name  : in String;
    50.                    mode       : in POSIX.access_mode);
    51.
    52.    procedure truncate (the_stream : in out IO.stream;
    53.                        to_length  : in KDF9.word := 0);
    54.
    55.    procedure close (the_stream : in out IO.stream);
    56.
    57.    procedure flush (the_stream  : in out IO.stream;
    58.                     a_byte_time : in KDF9.microseconds := 0);
    59.
    60.    -- Reassign an open stream to another file.
    61.    procedure reattach (the_stream : in out IO.stream;
    62.                        file_name  : in String;
    63.                        mode       : in POSIX.access_mode);
    64.
    65.    function is_open(the_stream : IO.stream)
    66.    return Boolean;
    67.
    68.    function bytes_moved(the_stream : IO.stream)
    69.    return KDF9.word;
    70.
    71.    function file_size (the_stream : IO.stream)
    72.    return Natural;
    73.
    74.    function column (the_stream : IO.stream)
    75.    return Natural;
    76.
    77.    procedure get_position (position   : out Natural;
    78.                            the_stream : in out IO.stream);
    79.
    80.    procedure set_position (position   : in Natural;
    81.                            the_stream : in out IO.stream;
    82.                            whence     : in POSIX.seek_origin := from_start);
    83.
    84.    procedure reset (the_stream : in out IO.stream);
    85.
    86.    procedure back_off (the_stream : in out IO.stream);
    87.    pragma Inline(back_off);
    88.
    89.    procedure get_byte (char       : out Character;
    90.                        the_stream : in out IO.stream);
    91.
    92.    -- get_bytes iterates get_byte over the_string, for convenience.
    93.    -- If uncounted then the output is not included in the_stream.bytes_moved.
    94.    procedure get_bytes (the_string : out String;
    95.                         the_stream : in out IO.stream;
    96.                         uncounted  : in Boolean := True);
    97.
    98.    -- True iff the last get_byte obtained a LF.
    99.    function a_LF_was_just_read (the_stream : IO.stream)
   100.    return Boolean;
   101.
   102.    -- get_char differs from get_byte in the treatment of line terminators.
   103.    -- CR, LF, and CRLF are all returned as a single LF character, so catering
   104.    --    for old MacOS, MSDOS, and OS X/UNIX/Linux external text-file formats.
   105.    procedure get_char (char       : out Character;
   106.                        the_stream : in out IO.stream);
   107.
   108.    -- peek_at_char uses get_char to inspect the next char to be delivered,
   109.    --    then invokes back_off so that it is left in the input stream.
   110.    procedure peek_at_char (char       : out Character;
   111.                            the_stream : in out IO.stream);
   112.
   113.    procedure put_byte (char       : in Character;
   114.                        the_stream : in out IO.stream);
   115.
   116.    -- put_bytes iterates put_byte over the_string, for convenience.
   117.    -- If uncounted then the output is not included in the_stream.bytes_moved.
   118.    procedure put_bytes (the_string : in String;
   119.                         the_stream : in out IO.stream;
   120.                         uncounted  : in Boolean := True);
   121.
   122.    -- put_EOL writes the host-appropriate line terminator (CRLF, or just LF)
   123.    procedure put_EOL (the_stream : in out IO.stream);
   124.
   125.    -- put_char differs from put_byte only in the treatment of line terminators.
   126.    -- If char is LF, then put_EOL is used to output a host-appropriate line terminator.
   127.    procedure put_char (char       : in Character;
   128.                        the_stream : in out IO.stream);
   129.
   130.    -- put_chars iterates put_bytes over the_string, for convenience.
   131.    procedure put_chars (the_string : in String;
   132.                         the_stream : in out IO.stream);
   133.
   134.    -- True iff the last put_byte wrote out a LF.
   135.    function a_LF_was_just_written (the_stream : IO.stream)
   136.    return Boolean;
   137.
   138.    function buffer_is_empty (the_stream : IO.stream)
   139.    return Boolean;
   140.    pragma Inline(buffer_is_empty);
   141.
   142.    function buffer_is_full (the_stream : IO.stream)
   143.    return Boolean;
   144.    pragma Inline(buffer_is_full);
   145.
   146.    -- Return the last output as a single string.
   147.    function contents (the_stream : IO.stream)
   148.    return String;
   149.
   150.    -- Make the_string appear to be input for the_stream (which must be empty).
   151.    procedure inject (the_string : in String;
   152.                      the_stream : in out IO.stream);
   153.
   154. private
   155.
   156.    -- N.B. in IO the term 'buffer' is used conventionally.
   157.    -- It does NOT refer to a KDF9 DMA channel.
   158.
   159.    -- IO_buffer_size is enough for a complete FD sector, lacking any better criterion.
   160.    IO_buffer_size : constant Positive := 320;
   161.
   162.    type stream is tagged limited
   163.       record
   164.          base_name   : String (1 .. 3) := "???";
   165.          is_open     : Boolean := False;
   166.          last_char   : Character := ' ';
   167.          block_size,
   168.          next_byte,
   169.          position,
   170.          column      : Natural := 0;
   171.          bytes_moved : KDF9.word := 0;
   172.          fd          : Natural;
   173.          IO_mode     : POSIX.access_mode range read_mode .. rd_wr_mode;
   174.          last_IO     : POSIX.access_mode range read_mode .. write_mode;
   175.          buffer      : String(1 .. IO_buffer_size);
   176.       end record;
   177.
   178. end IO;

 465 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\posix.adb
Source file time stamp: 2015-06-18 00:55:48
Compiled at: 2015-10-28 18:14:49

     1. -- posix.adb
     2. --
     3. -- Provide a binding to a small subset of POSIX I/O operations.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with System;
    20. --
    21. with Latin_1;
    22. with OS_specifics;
    23. with settings;
    24.
    25. use  Latin_1;
    26. use  OS_specifics;
    27. use  settings;
    28.
    29. package body POSIX is
    30.
    31.    pragma Unsuppress(All_Checks);
    32.
    33.    -- N.B. in POSIX the term 'buffer' is used conventionally.
    34.    --      It does NOT refer to a KDF9 DMA channel.
    35.
    36.    use type C.int, C.long;
    37.
    38.    procedure verify (IO_status : in Integer; what : in String := "") is
    39.    begin
    40.       if IO_status < 0 then
    41.          raise POSIX_IO_error with Integer'Image(IO_status) & " in " & what;
    42.       end if;
    43.    end verify;
    44.
    45.    procedure verify (IO_status : in C.long; what : in String := "") is
    46.    begin
    47.       if IO_status < 0 then
    48.          raise POSIX_IO_error with C.long'Image(IO_status) & " in " & what;
    49.       end if;
    50.    end verify;
    51.
    52.    procedure verify (IO_status : in C.int; what : in String := "") is
    53.    begin
    54.       if IO_status < 0 then
    55.          raise POSIX_IO_error with C.int'Image(IO_status) & " in " & what;
    56.       end if;
    57.    end verify;
    58.
    59.    function verify (IO_status : C.long; what : in String := "")
    60.    return POSIX.file_position is
    61.    begin
    62.       if IO_status < 0 then
    63.          raise POSIX_IO_error with C.long'Image(IO_status) & " in " & what;
    64.       else
    65.          return POSIX.file_position(IO_status);
    66.       end if;
    67.    end verify;
    68.
    69.    function verify (IO_status : C.int; what : in String := "")
    70.    return Integer is
    71.    begin
    72.       if IO_status < 0 then
    73.          raise POSIX_IO_error with C.int'Image(IO_status) & " in " & what;
    74.       else
    75.          return Integer(IO_status);
    76.       end if;
    77.    end verify;
    78.
    79.    function creat (name : C.char_array;  permissions : C.int)
    80.    return C.int;
    81.    pragma Import (C, creat);
    82.
    83.    function create (name : String;  permissions : POSIX.permission_set)
    84.    return Integer is
    85.       file_name : constant C.char_array := C.To_C(name, Append_Nul => True);
    86.    begin
    87.       return verify(creat(file_name, C.int(permissions)), "create: " & name);
    88.    end create;
    89.
    90.    function open (name : C.char_array;  mode : C.int)
    91.    return C.int;
    92.    pragma Import (C, open);
    93.
    94.    function open (name : String;  mode : POSIX.access_mode)
    95.    return Integer is
    96.       file_name : constant C.char_array := C.To_C(name, Append_Nul => True);
    97.    begin
    98.       return verify(open(file_name, C.int(mode)), "open file: " & name);
    99.    end open;
   100.
   101.    function ftruncate (fd : C.int;  to_length : C.long)
   102.    return C.long;
   103.    pragma Import (C, ftruncate);
   104.
   105.    procedure truncate (fd : Natural;  to_length : POSIX.file_position := 0) is
   106.    begin
   107.       verify(ftruncate(C.int(fd), C.long(to_length)), "truncate fd: " & Natural'Image(fd));
   108.    end truncate;
   109.
   110.    function lseek (fd : C.int;  to_offset : C.long;  whence : C.int)
   111.    return C.long;
   112.    pragma Import (C, lseek);
   113.
   114.    function seek (fd        : Natural;
   115.                   to_offset : POSIX.file_position;
   116.                   whence    : POSIX.seek_origin := from_start)
   117.    return POSIX.file_position is
   118.    begin
   119.       return verify(lseek(C.int(fd), C.long(to_offset), C.int(whence)),
   120.                     "seek fd: " & Natural'Image(fd));
   121.    end seek;
   122.
   123.    function read (fd : C.int;  buffer : System.Address;  count : C.int)
   124.    return C.int;
   125.    pragma Import (C, read);
   126.
   127.    function read (fd : Natural;  buffer : String;  count : Natural)
   128.    return Integer is
   129.       safe_count : constant C.int := C.int(Integer'Min(count, buffer'Length));
   130.    begin
   131.       return verify(read(C.int(fd), buffer'Address, safe_count),
   132.                     "read fd: " & Natural'Image(fd));
   133.    end read;
   134.
   135.    function write (fd : C.int;  buffer : System.Address;  count : C.int)
   136.    return C.int;
   137.    pragma Import (C, write);
   138.
   139.    function write (fd : Natural;  buffer : String;  count : Natural)
   140.    return Integer is
   141.       safe_count : constant C.int := C.int(Integer'Min(count, buffer'Length));
   142.    begin
   143.       return verify(write(C.int(fd), buffer'Address, safe_count),
   144.                     "write fd: " & Natural'Image(fd));
   145.    end write;
   146.
   147.    function close (fd : C.int)
   148.    return C.int;
   149.    pragma Import (C, close);
   150.
   151.    function close (fd : Natural)
   152.    return Integer is
   153.    begin
   154.       return verify(close(C.int(fd)), "close fd: " & Natural'Image(fd));
   155.    end close;
   156.
   157.    procedure ensure_ui_is_open is
   158.    begin
   159.       if not ui_is_open then
   160.          open_ui;
   161.       end if;
   162.    end ensure_ui_is_open;
   163.
   164.    function get_errno return C.int;
   165.    pragma Import (C, get_errno, "__get_errno");
   166.
   167.    function error_number return Integer is
   168.    begin
   169.       return Integer(get_errno);
   170.    end error_number;
   171.
   172.    procedure set_errno (error_number : in C.int);
   173.    pragma Import (C, set_errno, "__set_errno");
   174.
   175.    procedure set_error_number (error_number : in Integer) is
   176.    begin
   177.       set_errno(C.int(error_number));
   178.    end set_error_number;
   179.
   180.    procedure perror (error_message : in C.char_array);
   181.    pragma Import (C, perror);
   182.
   183.    procedure put_error_message (error_message : in String) is
   184.       message : constant C.char_array := C.To_C(error_message, Append_Nul => True);
   185.    begin
   186.       perror(message);
   187.       set_errno(0);
   188.    end put_error_message;
   189.
   190.    procedure prompt (message  : in String    := "?";
   191.                      response : out Character;
   192.                      default  : in Character := ' ') is
   193.       unix_prompt   : constant C.char_array := C.To_C("ee9: " & message, Append_Nul => True);
   194.       unix_response : C.char_array (0 .. 0);
   195.    begin
   196.       response := default;
   197.       if noninteractive_usage_is_enabled then
   198.          output_line("In non-interactive mode ee9 cannot get a reply to the prompt: ");
   199.          output_line("'" & message & "'.");
   200.          return;
   201.       end if;
   202.       ensure_ui_is_open;
   203.       loop
   204.          verify(write(C.int(ui_out_fd), unix_prompt'Address, unix_prompt'Length-1),
   205.                 "prompt: " & message);
   206.          verify(read(C.int(ui_in_fd), unix_response'Address, 1), "response");
   207.          if C.To_Ada(unix_response(0)) = LF then
   208.             return;
   209.          else
   210.             response := C.To_Ada(unix_response(0));
   211.             verify(read(C.int(ui_in_fd), unix_response'Address, 1),
   212.                    "skipping line terminator");
   213.             if C.To_Ada(unix_response(0)) = LF then
   214.                return;
   215.             end if;
   216.          end if;
   217.       end loop;
   218.    end prompt;
   219.
   220.    procedure output (message  : in String) is
   221.       unix_message : constant C.char_array := C.To_C(message, Append_Nul => False);
   222.    begin
   223.       if message = "" then
   224.          return;
   225.       end if;
   226.       ensure_ui_is_open;
   227.       verify(write(C.int(ui_out_fd), unix_message'Address, unix_message'Length),
   228.              "output: " & message);
   229.    end output;
   230.
   231.    procedure output_line (message : in String) is
   232.       message_line : constant String := message & EOL;
   233.    begin
   234.       output(message_line);
   235.    end output_line;
   236.
   237.    procedure output (message  : in Character) is
   238.    begin
   239.       ensure_ui_is_open;
   240.       verify(write(C.int(ui_out_fd), message'Address, 1), "output: " & message);
   241.    end output;
   242.
   243.    procedure input  (message  : out Character) is
   244.    begin
   245.       ensure_ui_is_open;
   246.       verify(read(C.int(ui_in_fd), message'Address, 1), "input");
   247.    end input;
   248.
   249.    procedure POSIX_exit (status : in C.int);
   250.    pragma Import (C, POSIX_exit, "exit");
   251.
   252.    procedure exit_program (status : in Natural) is
   253.    begin
   254.       POSIX_exit(C.int(status));
   255.    end exit_program;
   256.
   257. end POSIX;
   258.

Compiling: ../Source\posix.ads
Source file time stamp: 2015-06-18 00:55:46
Compiled at: 2015-10-28 18:14:49

     1. -- posix.ads
     2. --
     3. -- Provide a binding to a small subset of POSIX I/O operations.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Interfaces.C;
    20.
    21. package POSIX is
    22.
    23.    pragma Unsuppress(All_Checks);
    24.
    25.    package C renames Interfaces.C;
    26.
    27.    -- N.B. within POSIX the term 'buffer' is used conventionally.
    28.    -- It does NOT refer to a KDF9 DMA channel.
    29.
    30.    POSIX_IO_error   : exception;
    31.
    32.    type permission_set is mod 2**9;
    33.
    34.    world_read_permission  : constant permission_set := 4;
    35.    world_write_permission : constant permission_set := 2;
    36.    world_exec_permission  : constant permission_set := 1;
    37.
    38.    group_read_permission  : constant permission_set := 8 * world_read_permission;
    39.    group_write_permission : constant permission_set := 8 * world_write_permission;
    40.    group_exec_permission  : constant permission_set := 8 * world_exec_permission;
    41.
    42.    owner_read_permission  : constant permission_set := 8 * group_read_permission;
    43.    owner_write_permission : constant permission_set := 8 * group_write_permission;
    44.    owner_exec_permission  : constant permission_set := 8 * group_exec_permission;
    45.
    46.    function create (name        : String;
    47.                     permissions : POSIX.permission_set)
    48.    return Integer;
    49.
    50.    type access_mode is mod 3;
    51.
    52.    read_mode  : constant POSIX.access_mode := 0;
    53.    write_mode : constant POSIX.access_mode := 1;
    54.    rd_wr_mode : constant POSIX.access_mode := 2;
    55.
    56.    function open (name : String;
    57.                   mode : POSIX.access_mode)
    58.    return Integer;
    59.
    60.    type file_position is new C.long;
    61.
    62.    procedure truncate (fd        : Natural;
    63.                        to_length : POSIX.file_position := 0);
    64.
    65.    type seek_origin is mod 3;
    66.
    67.    from_start : constant POSIX.seek_origin := 0;
    68.    from_here  : constant POSIX.seek_origin := 1;
    69.    from_end   : constant POSIX.seek_origin := 2;
    70.
    71.    function seek (fd        : Natural;
    72.                   to_offset : POSIX.file_position;
    73.                   whence    : POSIX.seek_origin := from_start)
    74.    return POSIX.file_position;
    75.
    76.    function read (fd : Natural;  buffer : String;  count : Natural)
    77.    return Integer;
    78.
    79.    function write (fd : Natural;  buffer : String;  count : Natural)
    80.    return Integer;
    81.
    82.    function close (fd : Natural)
    83.    return Integer;
    84.
    85.    procedure put_error_message (error_message : in String);
    86.
    87.    --  get the task-safe error number
    88.    function error_number
    89.    return Integer;
    90.
    91.    --  set the task-safe error number
    92.    procedure set_error_number (error_number : in Integer);
    93.
    94.    procedure ensure_ui_is_open;
    95.
    96.    ui_in_fd, ui_out_fd : Natural;
    97.    ui_is_open          : Boolean := False;
    98.
    99.    procedure output (message  : in String);
   100.
   101.    procedure output (message  : in Character);
   102.
   103.    procedure output_line (message : in String);  -- output(message & EOL)
   104.
   105.    procedure input  (message  : out Character);
   106.
   107.    procedure prompt (message  : in  String := "?";
   108.                      response : out Character;
   109.                      default  : in  Character := ' ');
   110.
   111.    procedure exit_program (status : in Natural);
   112.
   113.    procedure verify (IO_status : in Integer; what : in String := "");
   114.
   115. end POSIX;

 258 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\kdf9-directors.adb
Source file time stamp: 2015-06-18 00:56:10
Compiled at: 2015-10-28 18:14:50

     1. -- kdf9.directors.adb
     2. --
     3. -- Implement the APIs  (OUTs) of the supported KDF9 Directors.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with dumping;
    20. with exceptions;
    21. with formatting;
    22. with HCI;
    23. with IO;
    24. with IOC;
    25. with IOC.assignment;
    26. with IOC.two_shift.FW;
    27. with IOC.two_shift.TR;
    28. with IOC.magtape;
    29. with KDF9.CPU;
    30. with KDF9.store;
    31. with logging.file;
    32. with settings;
    33. with state_display;
    34. with toggle_the_shared_buffer;
    35. with tracing;
    36.
    37. use  dumping;
    38. use  exceptions;
    39. use  formatting;
    40. use  HCI;
    41. use  IOC;
    42. use  IOC.assignment;
    43. use  IOC.two_shift.FW;
    44. use  IOC.two_shift.TR;
    45. use  IOC.magtape;
    46. use  KDF9.store;
    47. use  logging.file;
    48. use  settings;
    49. use  state_display;
    50. use  tracing;
    51.
    52. package body KDF9.Directors is
    53.
    54.    pragma Unsuppress(All_Checks);
    55.
    56.    procedure log_API_message (message  : in String;
    57.                               skip     : in Natural := 1;
    58.                               complete : in Boolean := True) is
    59.    begin
    60.       if API_logging_is_requested then
    61.          log_ee9_status(message, skip, complete);
    62.       end if;
    63.    end log_API_message;
    64.
    65.    -- This is the actual wall clock time at which the program was loaded.
    66.    -- If signature hashing is enabled, it stays at zero to get a repeatable hash.
    67.    the_time_of_loading : KDF9.microseconds := 0;
    68.
    69.    -- Set the base for virtual elapsed time reckoning.
    70.    procedure set_the_time_of_loading (the_time : in KDF9.microseconds) is
    71.    begin
    72.       the_time_of_loading := the_time;
    73.    end set_the_time_of_loading;
    74.
    75.    -- Emulate a subset of the EGDON Director's OUT API.
    76.    procedure do_an_EGDON_OUT (OUT_number : in KDF9.word) is
    77.    begin
    78.       -- STUB: EGDON OUTs are not yet supported.
    79.       raise NYI_trap with "EGDON OUTs are not yet supported";
    80.    end do_an_EGDON_OUT;
    81.
    82.    -- Implement a subset of the Time Sharing Director's OUT 8 API.
    83.    procedure do_an_OUT_8 is
    84.
    85.       function destination_device_for (the_stream : KDF9.word)
    86.       return IOC.device_number is
    87.       begin
    88.          case the_stream is
    89.             when 8#00#..8#07# =>
    90.                return FW0_number;
    91.             when 8#10#..8#16# =>
    92.                return TP0_number;
    93.             when 8#17# =>
    94.                return TP1_number;
    95.             when 8#20#..8#27# | 8#60#..8#67# =>
    96.                return TP1_number;
    97.             when 8#30#..8#37# | 8#70#..8#77# =>
    98.                return LP0_number;
    99.             when others =>
   100.                log_ee9_status("OUT 8: invalid stream #" & oct_of(the_stream));
   101.                trap_invalid_instruction("OUT 8: invalid stream number");
   102.                return(ND0_number);  -- Should never happen, due to trap above.
   103.          end case;
   104.       end destination_device_for;
   105.
   106.       the_stream : KDF9.word;
   107.       Q          : KDF9.Q_register;
   108.       FW_query   : Boolean;
   109.
   110.       procedure prepare_OUT8_to_FW0 is
   111.       begin
   112.          -- The logic of FW streams is rather complex, to preserve the layout of the typescript.
   113.          -- There are three significant aspects.
   114.
   115.          -- 1. The message is truncated if longer than 8 words.
   116.          if Q.M - Q.I > 8 then
   117.             Q.M := Q.I + 8;
   118.          end if;
   119.
   120.          -- 2. It must not contain LS or HT; ';' in the last word; nor ';' other than in byte 7;
   121.          --    but anything after an End Message can safely be ignored.
   122.          word_loop: for w in Q.I+1 .. Q.M loop
   123.             for c in KDF9.symbol_number'Range loop
   124.                declare
   125.                   s : constant KDF9.symbol := fetch_symbol(w, c);
   126.                begin
   127.                   if s = KDF9.Line_Shift                       or else
   128.                         s = KDF9.Tabulation                    or else
   129.                            ((s = KDF9.Semi_Colon) and
   130.                             (c /= 7 or  w = Q.M or not FW_query)) then
   131.                      log_ee9_status("OUT 8: failure 730, invalid data for FW");
   132.                      trap_invalid_instruction("OUT 8: invalid data for FW");
   133.                   end if;
   134.          exit word_loop when s = KDF9.Semi_Colon or s = KDF9.End_Message;
   135.                end;
   136.             end loop;
   137.          end loop word_loop;
   138.
   139.          -- 3. The Director takes a new line for each OUT 8 message to the FW.
   140.          -- It sets up the format effector(s) in the first word of the OUT 8 area.
   141.          declare
   142.             FW_prefix : constant KDF9.word := 8#77_77_77_77_77_77_07_02#;  -- CN LS
   143.             package FW renames IOC.two_shift.FW;
   144.             the_FW : FW.device renames FW.device(buffer(FW0_number).all);
   145.          begin
   146.             if a_LF_was_just_read(the_FW) then
   147.                -- Replace the redundant Line Shift with a Word Filler character.
   148.                store_word(FW_prefix or 8#77#, Q.I);
   149.             else
   150.                -- The initial Line Shift is needed.
   151.                store_word(FW_prefix, Q.I);
   152.             end if;
   153.          end;
   154.       end prepare_OUT8_to_FW0;
   155.
   156.    begin
   157.       pop;
   158.       Q := as_Q(pop);  -- the N2 parameter
   159.
   160.       -- An OUT 8 to the FW for a query must have D0 of the control word  set.
   161.       FW_query := (Q.C and 8#1_00000#) /= 0;
   162.       if FW_query then
   163.          Q.C := FW0_number;
   164.       end if;
   165.
   166.       --
   167.          -- OUT 8 'output spooling'.
   168.       --
   169.
   170.       if Q.C = Q.I and Q.I = Q.M then
   171.          -- The N2 parameter specifies stream closure.
   172.          the_trace_operand := as_word(Q);
   173.          flush(buffer(destination_device_for(KDF9.word(Q.C))).all);
   174.          log_API_message("OUT 8: closes stream #" & oct_of(Q.C, 2));
   175.          return;
   176.       end if;
   177.
   178.       take_note_of(as_word(Q));
   179.
   180.       -- The N2 parameter specifies a block starting with the stream number.
   181.       validate_access(Q.I);
   182.       the_stream := fetch_word(Q.I);
   183.       the_trace_operand := the_stream;
   184.       Q.C := destination_device_for(the_stream);
   185.
   186.       if is_unallocated(buffer(Q.C)) then
   187.          set_state_of(buffer(Q.C), allocated => True);
   188.       end if;
   189.
   190.       if Q.M <= Q.I then
   191.          log_ee9_status("OUT 8: invalid M-part #" & oct_of(Q.M));
   192.          trap_invalid_instruction("OUT 8: invalid M-part");
   193.       end if;
   194.
   195.       -- Perform the transfer at once (no spooling is implemented).
   196.
   197.       if Q.C /= FW0_number then
   198.          -- For non-FW streams, the first word of the OUT 8 area is not transferred.
   199.          Q.I := Q.I + 1;
   200.       else
   201.          -- The logic for FW streams is more complex, to preserve the layout of the typescript.
   202.          prepare_OUT8_to_FW0;
   203.       end if;
   204.
   205.       -- OUT 8 transfers always go to End Message.
   206.       POB(Q, False);
   207.
   208.    exception
   209.       when IO.end_of_stream =>
   210.          log_ee9_status("OUT 8: no device file for stream #"
   211.                       & oct_of(KDF9.Q_part(the_stream))
   212.                        );
   213.          trap_invalid_instruction("OUT 8: no device file for stream");
   214.    end do_an_OUT_8;
   215.
   216.    -- Emulate a subset of the Time Sharing Director's OUT API.
   217.    procedure do_a_TSD_OUT (OUT_number : in KDF9.word) is
   218.
   219.       -- Return a time in µs as 48-bit seconds to 23 integral places.
   220.       function OUT_time (microseconds : KDF9.microseconds)
   221.       return KDF9.word is
   222.       begin
   223.            -- 2**18 / 15625 = 2**24 / 1E6, with reduced risk of overflow.
   224.          return KDF9.word(microseconds * 2**18 / 15625);
   225.       end OUT_time;
   226.
   227.       procedure validate_buffer_number (parameter : in KDF9.Q_part) is
   228.       begin
   229.          if parameter > 15 then
   230.             log_ee9_status("the given device #"
   231.                           & oct_of(parameter)
   232.                           & " is invalid in OUT "
   233.                           & KDF9.word'Image(out_number)
   234.                            );
   235.             trap_invalid_instruction("invalid buffer number");
   236.          end if;
   237.       end validate_buffer_number;
   238.
   239.       procedure select_the_next_device_from_among
   240.          (device_0, device_1 : in  KDF9.buffer_number;
   241.           wanted_device_type : in  KDF9.word;
   242.           chosen_device      : out KDF9.buffer_number) is
   243.       begin
   244.          if is_unallocated(buffer(device_0)) then
   245.             chosen_device := device_0;
   246.          elsif is_unallocated(buffer(device_1)) then
   247.             chosen_device := device_1;
   248.          else
   249.             trap_invalid_instruction("OUT 5: no device of type"
   250.                                    & KDF9.word'Image(wanted_device_type)
   251.                                    & " is available");
   252.          end if;
   253.       end select_the_next_device_from_among;
   254.
   255.       the_tape_punch_WAS_configured : constant Boolean := not the_graph_plotter_is_configured;
   256.       B : KDF9.Q_part;
   257.       W : KDF9.word;
   258.       P : KDF9.pair;
   259.
   260.    begin
   261.       case OUT_number is
   262.
   263.          when 0 =>
   264.             -- Terminate program.
   265.             ensure_that_the_nest_holds_an_operand;
   266.             pop;
   267.             log_API_message("OUT 0: end of run");
   268.             raise program_exit;
   269.
   270.          when 1 =>
   271.             -- Terminate program and overlay a new program.
   272.             ensure_that_the_nest_holds(at_least => 3);
   273.             pop;
   274.             P := pop;
   275.             P := CPU.shift_logical(P, 24);
   276.             if trimmed(to_string(P)) = "KMW0301--UPU" then
   277.                complete_all_extant_transfers;  -- To get an accurate elapsed time.
   278.                log_API_message("OUT 1: ICR ="
   279.                              & KDF9.order_counter'Image(ICR)
   280.                              & "; RAN/EL ="
   281.                              & KDF9.microseconds'Image(the_CPU_time)
   282.                              & " /"
   283.                              & KDF9.microseconds'Image(the_clock_time)
   284.                              & " KDF9 us"
   285.                               );
   286.                if the_log_is_wanted and nr_of_post_dumping_areas /= 0 then
   287.                   log_rule;
   288.                   log_title("Post-run Dump:");
   289.                   print_postrun_dump_areas;
   290.                end if;
   291.
   292.                remove_prerun_dump_areas;
   293.                remove_postrun_dump_areas;
   294.                get_settings_from_file("2");
   295.
   296.                if the_tape_punch_WAS_configured then
   297.                   toggle_the_shared_buffer;
   298.                end if;
   299.
   300.                log_API_message("OUT 1: the Whetstone Controller overlays the Translator",
   301.                                skip => 0);
   302.                W := fetch_word(1);
   303.                log_new_line;
   304.                reattach_TR0(to_the_file => "Binary/KMW0301--UPU");
   305.                load_a_program;
   306.                store_word(W, 1);
   307.                the_V_bit := 0;
   308.                the_T_bit := 0;
   309.                -- Setting NIA must follow program loading, as it fetches E0 into the IWBs.
   310.                set_NIA_to((0, 0));
   311.                clear_retro_FIFO;
   312.                clear_IOC_FIFO;
   313.                clear_interrupt_FIFO;
   314.                display_execution_modes;
   315.
   316.                if the_external_trace_is_enabled then
   317.                   log_new_line(the_external_trace_file);
   318.                   log(the_external_trace_file,
   319.                       "ee9: Running overlay KMW0301--UPU, the Whetstone Controller.");
   320.                   log_new_line(the_external_trace_file);
   321.                   log_an_external_trace_header;
   322.                end if;
   323.
   324.                the_code_space_has_been_marked := False;
   325.                raise mode_change_request;
   326.
   327.             elsif trimmed(to_string(P)) = "KMW0201--UPU" then
   328.
   329.                -- Thw Whetstone Controller is trying to overlay itself with the Translator.
   330.                -- This is so inconvenient in practice that I simply prevent it.
   331.                log_API_message("OUT 1: ee9 will not return to the Whetstone Translator");
   332.                raise program_exit;
   333.
   334.             else
   335.
   336.                -- Some other overlay is being attempted, but this is not yet implemented.
   337.                log_API_message("OUT 1: ee9 does not yet support an overlay by '"
   338.                              & trimmed(to_string(P))
   339.                              & "'");
   340.                raise NYI_trap;
   341.
   342.             end if;  -- OUT 1
   343.
   344.          when 2 =>
   345.             -- Restart newly self-overwritten program.
   346.             ensure_that_the_nest_holds_2_operands;
   347.             pop;
   348.             W := pop;
   349.             the_trace_operand := W;
   350.             reset_the_program_state;
   351.             for b in buffer'Range loop
   352.                if not is_unallocated(buffer(b)) then
   353.                   set_state_of(buffer(b), allocated => False);
   354.                end if;
   355.             end loop;
   356.             set_state_of(buffer(0), allocated => True);  -- FW0 is always pre-allocated.
   357.              -- Set the new time limit in E1U.
   358.             store_halfword(W * 2**24, KDF9.address'(1), 0);
   359.              -- Set the new store limit in E1L.
   360.             store_halfword((KDF9.word'(max_address)) * 2**24, KDF9.address'(1), 1);
   361.             log_API_message("OUT 2: restart with time limit = " & KDF9.word'Image(W));
   362.
   363.          when 3 =>
   364.             -- Get the virtual CPU time used, allowing for previous overlays.
   365.             ensure_that_the_nest_holds_an_operand;
   366.             W := OUT_time(the_CPU_time);
   367.             write_top(W);
   368.             the_trace_operand := W;
   369.
   370.          when 4 =>
   371.             -- Allocate the deck with a tape having a 1-word label.
   372.             ensure_that_the_nest_holds_2_operands;
   373.             pop;
   374.             W := pop;
   375.             take_note_of(W);
   376.             declare
   377.                label : constant magtape.short_label := magtape.short_label(to_string(W));
   378.             begin
   379.                find_tape_labelled(label, B, W);  -- W is not used in OUT 4
   380.                push(KDF9.word(B));
   381.                the_trace_operand := read_top;
   382.                validate_buffer_number(B);
   383.                if W = 0 then
   384.                   log_API_message("OUT 4: requests MT labelled ""_Z_E_R_O""; gets "
   385.                                 & logical_device_name_of(buffer(B).all)
   386.                                 & ", TSN """
   387.                                 & trimmed(to_string(W))
   388.                                 & """"
   389.                                  );
   390.                else
   391.                   log_API_message("OUT 4: requests MT labelled """
   392.                                 & trimmed(String(label))
   393.                                 & """; gets "
   394.                                 & logical_device_name_of(buffer(B).all)
   395.                                 & ", TSN """
   396.                                 & trimmed(to_string(W))
   397.                                 & """"
   398.                                  );
   399.                end if;
   400.             end;
   401.             set_state_of(buffer(B), allocated => True);
   402.
   403.          when 5 =>
   404.             -- Allocate an I/O device.
   405.             ensure_that_the_nest_holds_2_operands;
   406.             pop;
   407.             W := read_top;
   408.             take_note_of(W);
   409.
   410.             case W is
   411.                -- 8 was added to the code to pre-allocate a device.
   412.                -- I treat pre-allocating and allocating the same way here.
   413.                when FW_OUT5_code | FW_OUT5_code+8 =>
   414.                   B := FW0_number;  -- Always allowed, no checking performed.
   415.                when TP_OUT5_code | TP_OUT5_code+8 =>
   416.                   select_the_next_device_from_among(TP0_number, TP1_number, W, B);
   417.                when TR_OUT5_code | TR_OUT5_code+8 =>
   418.                   select_the_next_device_from_among(TR1_number, TR0_number, W, B);
   419.                   set_case(IOC.two_shift.TR.device(buffer(B).all));
   420.                when LP_OUT5_code | LP_OUT5_code+8 =>
   421.                   select_the_next_device_from_among(LP0_number, LP0_number, W, B);
   422.                when CR_OUT5_code | CR_OUT5_code+8 =>
   423.                   select_the_next_device_from_among(CR0_number, CR0_number, W, B);
   424.                when CP_OUT5_code | CP_OUT5_code+8 =>
   425.                   select_the_next_device_from_among(CP0_number, CP0_number, W, B);
   426.                when GP_OUT5_code | GP_OUT5_code+8 =>
   427.                   if the_graph_plotter_is_configured then
   428.                      select_the_next_device_from_among(GP0_number, GP0_number, W, B);
   429.                   else
   430.                      trap_invalid_instruction("OUT 5: no graph plotter has been configured");
   431.                   end if;
   432.                when others =>
   433.                   trap_invalid_instruction("OUT 5: requested an invalid device type #"
   434.                                          & oct_of(W));
   435.             end case;
   436.
   437.             pop;
   438.             push(KDF9.word(B));
   439.             the_trace_operand := read_top;
   440.             set_state_of(buffer(B), allocated => True);
   441.             log_API_message("OUT 5: requests a device of type #"
   442.                           & oct_of(KDF9.Q_part(W), 2)
   443.                           & "; gets "
   444.                           & logical_device_name_of(buffer(B).all)
   445.                            );
   446.
   447.          when 6 =>
   448.             -- Deallocate an I/O device.
   449.             ensure_that_the_nest_holds_2_operands;
   450.             pop;
   451.             W := pop;
   452.             the_trace_operand := W;
   453.             B := KDF9.Q_part(W);
   454.             validate_buffer_number(B);
   455.             if is_unallocated(buffer(B)) then
   456.                trap_invalid_instruction("OUT 6: device #"
   457.                                       & oct_of(B)
   458.                                       & ", i.e. "
   459.                                       & logical_device_name_of(buffer(B).all)
   460.                                       & ", is not allocated to this program"
   461.                                        );
   462.             elsif buffer(B).kind = MT_kind then
   463.                -- Rewind the tape and unload it.
   464.                PMD(buffer(B).all, KDF9.Q_register'(B, 0, 0), set_offline => True);
   465.             end if;
   466.             set_state_of(buffer(B), allocated => False);
   467.             log_API_message("OUT 6: releases " & logical_device_name_of(buffer(B).all));
   468.
   469.          when 7 =>
   470.             -- Deallocate an allocated MT.
   471.             ensure_that_the_nest_holds_2_operands;
   472.             pop;
   473.             W := pop;
   474.             the_trace_operand := W;
   475.             B := KDF9.Q_part(W);
   476.             validate_buffer_number(B);
   477.             if is_unallocated(buffer(B)) then
   478.                trap_invalid_instruction("OUT 7: device #"
   479.                                       & oct_of(B)
   480.                                       & ", i.e. "
   481.                                       & logical_device_name_of(buffer(B).all)
   482.                                       & ", is not allocated to this program"
   483.                                        );
   484.             elsif buffer(B).kind = MT_kind then
   485.                -- Rewind the tape, but do not unload it.
   486.                PMD(buffer(B).all, KDF9.Q_register'(B, 0, 0), set_offline => False);
   487.                set_state_of(buffer(B), allocated => False);
   488.                log_API_message("OUT 7: releases " & logical_device_name_of(buffer(B).all));
   489.             else
   490.                trap_invalid_instruction("OUT 7: device #"
   491.                                       & oct_of(B)
   492.                                       & ", i.e. "
   493.                                       & logical_device_name_of(buffer(B).all)
   494.                                       & ", is not a MT"
   495.                                        );
   496.             end if;
   497.
   498.          when 8 =>
   499.             -- Spool output.
   500.             ensure_that_the_nest_holds_2_operands;
   501.             do_an_OUT_8;
   502.
   503.          when 9 =>
   504.             -- Get the time of day, in seconds since midnight to 23 integral places.
   505.             -- A TOD clock is simulated using the real TOD at which the program was
   506.             --    loaded, and the virtual time that has elapsed since.
   507.             ensure_that_the_nest_holds_an_operand;
   508.             W := OUT_time(the_time_of_loading + the_clock_time);
   509.             write_top(W);
   510.             the_trace_operand := W;
   511.
   512.          when 10 =>
   513.             -- Allocate the deck with a tape having a 2-word label.
   514.             ensure_that_the_nest_holds(at_least => 3);
   515.             pop;
   516.             P := pop;
   517.             declare
   518.                label : constant magtape.long_label := magtape.long_label(to_string(P));
   519.             begin
   520.                find_tape_labelled(label, B, W);
   521.                push(KDF9.word(B));
   522.                take_note_of(read_top);
   523.                push(W);
   524.                the_trace_operand := read_top;
   525.                validate_buffer_number(B);
   526.                log_API_message("OUT 10: requests MT labelled """
   527.                              & trimmed(String(label))
   528.                              & """; gets "
   529.                              & logical_device_name_of(buffer(B).all)
   530.                              & ", TSN """
   531.                              & trimmed(to_string(W))
   532.                              & """"
   533.                               );
   534.             end;
   535.             set_state_of(buffer(B), allocated => True);
   536.
   537.          when 17 =>
   538.             -- Get the CPU Time and the Notional Elapsed Time in seconds to 23 integral places.
   539.             -- In program mode, the Notional Elapsed Time is the same as the_clock_time.
   540.             ensure_that_the_nest_holds_an_operand;
   541.             pop;
   542.             ensure_that_the_nest_has_room_for_2_results;
   543.             W := OUT_time(the_CPU_time);
   544.             push(OUT_time(the_clock_time));
   545.             push(W);
   546.             the_trace_operand := W;
   547.
   548.          when others =>
   549.             raise NYI_trap;
   550.
   551.       end case;
   552.
   553.
   554.    end do_a_TSD_OUT;
   555.
   556. end KDF9.Directors;
   557.

Compiling: ../Source\kdf9-directors.ads
Source file time stamp: 2015-06-18 00:56:08
Compiled at: 2015-10-28 18:14:50

     1. -- kdf9.directors.ads
     2. --
     3. -- Implement the APIs  (OUTs) of the supported KDF9 Directors.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package KDF9.Directors is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    -- Emulate a subset of the EGDON Director's OUT API.
    24.    procedure do_an_EGDON_OUT (OUT_number : in KDF9.word);
    25.
    26.    -- Implement a subset of the Time Sharing Director's OUT 8 API.
    27.    procedure do_an_OUT_8;
    28.
    29.    -- Emulate a subset of the Time Sharing Director's OUT API.
    30.    procedure do_a_TSD_OUT (OUT_number : in KDF9.word);
    31.
    32.    -- These are the device-type codes to be given when requesting
    33.    --    the allocation of a peripheral with TSD OUT 5,
    34.    --       according to the Manual and the document
    35.    --          "Order Code Notes 18-Further OUTs".
    36.
    37.    FW_OUT5_code : constant := 0;
    38.    TP_OUT5_code : constant := 1;
    39.    TR_OUT5_code : constant := 2;
    40.    LP_OUT5_code : constant := 3;
    41.    CR_OUT5_code : constant := 4;
    42.    CP_OUT5_code : constant := 7;
    43.    GP_OUT5_code : constant := 8#20#;
    44.
    45.    -- Set the base for virtual elapsed time reckoning.
    46.    procedure set_the_time_of_loading (the_time : in KDF9.microseconds);
    47.
    48. end KDF9.Directors;

 557 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\kdf9-tod_clock.adb
Source file time stamp: 2015-06-18 00:56:02
Compiled at: 2015-10-28 18:14:57

     1. -- kdf9-tod_clock.adb
     2. --
     3. -- functions that implement timing for Director emulation.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Calendar;
    20. with Ada.Calendar.Formatting;
    21.
    22. use  Ada.Calendar;
    23. use  Ada.Calendar.Formatting;
    24.
    25. package body KDF9.TOD_clock is
    26.
    27.    pragma Unsuppress(All_Checks);
    28.
    29.    function todays_date_28n_years_ago
    30.    return KDF9.word is
    31.
    32.       -- For values of i in 0..99, return two 6-bit KDF9 decimal digits.
    33.       function as_2_digits (i : KDF9.word)
    34.       return KDF9.word is
    35.          zero : constant KDF9.word := 8#20#;  -- KDF9 code for '0'.
    36.       begin
    37.          return (i/10 + zero)*64 or (i mod 10 + zero);
    38.       end as_2_digits;
    39.
    40.       slash : constant KDF9.word := 8#17#;  -- The result is in the form DD/MM/YY.
    41.       today : constant Ada.Calendar.Time := Ada.Calendar.Clock;
    42.
    43.       year, month, day, hour, minute, second, sub_second : KDF9.word;
    44.
    45.    begin  -- todays_date_28n_years_ago
    46.       Split(today,
    47.             Year_Number(year),
    48.             Month_Number(month),
    49.             Day_Number(day),
    50.             Hour_Number(hour),
    51.             Minute_Number(minute),
    52.             Second_Number(second),
    53.             Second_Duration(sub_second)
    54.            );
    55.       loop  -- Repeat n > 0 times, assuming no time travel into the past!
    56.          year := year - 28;
    57.       exit when year < 2000;
    58.       end loop;
    59.       return (as_2_digits(day)*64   or slash) * 64**5  -- DD/.....
    60.           or (as_2_digits(month)*64 or slash) * 64**2  --    MM/..
    61.           or (as_2_digits((year) mod 100));            --       YY
    62.    end todays_date_28n_years_ago;
    63.
    64.    function the_time_of_day
    65.    return KDF9.microseconds is
    66.       today : constant Ada.Calendar.Time := Ada.Calendar.Clock;
    67.       year, month, day, hour, minute, second, sub_second : KDF9.word;
    68.    begin
    69.       Split(today,
    70.             Year_Number(year),
    71.             Month_Number(month),
    72.             Day_Number(day),
    73.             Hour_Number(hour),
    74.             Minute_Number(minute),
    75.             Second_Number(second),
    76.             Second_Duration(sub_second)
    77.            );
    78.       return KDF9.microseconds(hour*3600 + minute*60 + second) * 1_000_000;
    79.    end the_time_of_day;
    80.
    81.
    82. end KDF9.TOD_clock;

Compiling: ../Source\kdf9-tod_clock.ads
Source file time stamp: 2015-06-18 00:56:02
Compiled at: 2015-10-28 18:14:57

     1. -- kdf9-tod_clock.ads
     2. --
     3. -- functions that implement timing for Director emulation.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package KDF9.TOD_clock is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    -- The date a multiple of 28 years ago has the same day/date correspondence as today.
    24.    -- To avoid exposing KDF9's lack of Y2K compliance, ee9 uses such a date before 2000.
    25.    -- 8-)
    26.    -- The result is a word of 8 KDF9 characters in the format DD/MM/YY.
    27.    function todays_date_28n_years_ago
    28.    return KDF9.word;
    29.
    30.    -- The time in microseconds since midnight.
    31.    function    the_time_of_day
    32.    return KDF9.microseconds;
    33.
    34. end KDF9.TOD_clock;

 82 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\disassembly.adb
Source file time stamp: 2015-06-18 00:57:02
Compiled at: 2015-10-28 18:14:59

     1. -- disassembly.adb
     2. --
     3. -- Produce dis-assembled instructions in an approximation to KDF9 Usercode.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with formatting;
    20. with KDF9.CPU;
    21. with KDF9.compressed_opcodes;
    22.
    23. use  formatting;
    24. use  KDF9.CPU;
    25. use  KDF9.compressed_opcodes;
    26.
    27. package body disassembly is
    28.
    29.    pragma Unsuppress(All_Checks);
    30.
    31.    function machine_code (decoded : KDF9.decoded_order)
    32.    return String is
    33.    begin
    34.       case decoded.kind is
    35.          when one_syllable_order =>
    36.             return "#" & oct_of(decoded.order.syllable_0);
    37.          when two_syllable_order =>
    38.             return "#" & oct_of(decoded.order.syllable_0)
    39.                  & ":" & oct_of(decoded.order.syllable_1);
    40.          when normal_jump_order | data_access_order=>
    41.             return "#" & oct_of(decoded.order.syllable_0)
    42.                  & ":" & oct_of(decoded.order.syllable_1)
    43.                  & ":" & oct_of(decoded.order.syllable_2);
    44.       end case;
    45.    end machine_code;
    46.
    47.    function one_syllable_order_name (decoded : KDF9.decoded_order)
    48.    return String is
    49.    begin
    50.       case decoded.syndrome is
    51.          when VR =>
    52.             return "VR";
    53.          when TO_TR =>
    54.             return "=TR";
    55.          when BITS =>
    56.             return "BITS";
    57.          when XF =>
    58.             return "×F";
    59.          when XDF =>
    60.             return "×DF";
    61.          when XPLUSF =>
    62.             return "×+F";
    63.          when NEGD =>
    64.             return "NEGD";
    65.          when OR_9 =>
    66.             return "OR";
    67.          when PERM =>
    68.             return "PERM";
    69.          when TOB =>
    70.             return "TOB";
    71.          when ROUNDH =>
    72.             return "ROUNDH";
    73.          when NEV =>
    74.             return "NEV";
    75.          when ROUND =>
    76.             return "ROUND";
    77.          when DUMMY =>
    78.             return "DUMMY";
    79.          when ROUNDF =>
    80.             return "ROUNDF";
    81.          when ROUNDHF =>
    82.             return "ROUNDHF";
    83.          when MINUSDF =>
    84.             return "-DF";
    85.          when PLUSDF =>
    86.             return "+DF";
    87.          when FLOAT_9 =>
    88.             return "FLOAT";
    89.          when FLOATD =>
    90.             return "FLOATD";
    91.          when ABS_9 =>
    92.             return "ABS";
    93.          when NEG =>
    94.             return "NEG";
    95.          when ABSF =>
    96.             return "ABSF";
    97.          when NEGF =>
    98.             return "NEGF";
    99.          when MAX =>
   100.             return "MAX";
   101.          when NOT_9 =>
   102.             return "NOT";
   103.          when XD =>
   104.             return "×D";
   105.          when X_frac =>
   106.             return "×";
   107.          when MINUS =>
   108.             return "-";
   109.          when SIGN =>
   110.             return "SIGN";
   111.          when ZERO =>
   112.             return "ZERO";
   113.          when DUP =>
   114.             return "DUP";
   115.          when DUPD =>
   116.             return "DUPD";
   117.          when DIVI =>
   118.             return "DIVI";
   119.          when FIX =>
   120.             return "FIX";
   121.          when STR =>
   122.             return "STR";
   123.          when CONT =>
   124.             return "CONT";
   125.          when REVD =>
   126.             return "REVD";
   127.          when ERASE =>
   128.             return "ERASE";
   129.          when MINUSD =>
   130.             return "-D";
   131.          when AND_9 =>
   132.             return "AND";
   133.          when PLUS =>
   134.             return "+";
   135.          when PLUSD =>
   136.             return "+D";
   137.          when DIV =>
   138.             return "DIV";
   139.          when DIVD =>
   140.             return "DIVD";
   141.          when DIVF =>
   142.             return "DIVF";
   143.          when DIVDF =>
   144.             return "DIVDF";
   145.          when DIVR =>
   146.             return "DIVR";
   147.          when REV =>
   148.             return "REV";
   149.          when CAB =>
   150.             return "CAB";
   151.          when FRB =>
   152.             return "FRB";
   153.          when STAND =>
   154.             return "STAND";
   155.          when NEGDF =>
   156.             return "NEGDF";
   157.          when MAXF =>
   158.             return "MAXF";
   159.          when PLUSF =>
   160.             return "+F";
   161.          when MINUSF =>
   162.             return "-F";
   163.          when SIGNF =>
   164.             return "SIGNF";
   165.          when others =>
   166.             return machine_code(decoded);
   167.       end case;
   168.    end one_syllable_order_name;
   169.
   170.    function two_syllable_order_name (decoded : KDF9.decoded_order)
   171.    return String is
   172.
   173.       k : constant String := trimmed(KDF9.Q_number'Image(decoded.Qk));
   174.       q : constant String := trimmed(KDF9.Q_number'Image(decoded.Qq));
   175.
   176.       function shift_count return String is
   177.          constant_flag : constant := 1;
   178.          fixed_shift   : CPU.signed_Q_part;
   179.       begin
   180.          if (decoded.order.syllable_1 and constant_flag) /= 0  then
   181.             fixed_shift := resign(KDF9.Q_part(decoded.order.syllable_1/2));
   182.             if fixed_shift > 63 then
   183.                fixed_shift := fixed_shift - 128;
   184.             end if;
   185.             return optional(fixed_shift<0, "", "+")
   186.                  & trimmed(CPU.signed_Q_part'Image(fixed_shift));
   187.          else
   188.             return "C" & q;
   189.          end if;
   190.       end shift_count;
   191.
   192.       function IO_order_name (decoded : KDF9.decoded_order)
   193.       return String is
   194.          IO_opcode : constant KDF9.syndrome := (decoded.Qk and not manual_bit);
   195.       begin
   196.          case decoded.syndrome is
   197.
   198.             when PARQq =>
   199.                return "PARQ" & q;
   200.
   201.             when PIAQq_PICQq_CLOQq_TLOQq =>
   202.                case IO_opcode is
   203.                   when PIAQq_bits =>
   204.                      return "PIAQ" & q;
   205.                   when PICQq_bits =>
   206.                      return "PICQ" & q;
   207.                   when CLOQq_bits =>
   208.                      return "CLOQ" & q;
   209.                   when TLOQq_bits =>
   210.                      return "TLOQ" & q;
   211.                   when others =>
   212.                      return machine_code(decoded);
   213.                end case;
   214.
   215.             when PIBQq_PIDQq =>
   216.                case IO_opcode is
   217.                   when PIBQq_bits =>
   218.                      return "PIBQ" & q;
   219.                   when PIDQq_bits =>
   220.                      return "PIDQ" & q;
   221.                   when others =>
   222.                      return machine_code(decoded);
   223.                end case;
   224.
   225.             when PIEQq_PIGQq =>
   226.                case IO_opcode is
   227.                   when PIEQq_bits =>
   228.                      return "PIEQ" & q;
   229.                   when PIGQq_bits =>
   230.                      return "PIGQ" & q;
   231.                   when others =>
   232.                      return machine_code(decoded);
   233.                end case;
   234.
   235.             when PIFQq_PIHQq =>
   236.                case IO_opcode is
   237.                   when PIFQq_bits =>
   238.                      return "PIFQ" & q;
   239.                   when PIHQq_bits =>
   240.                      return "PIHQ" & q;
   241.                   when others =>
   242.                      return machine_code(decoded);
   243.                end case;
   244.
   245.             when PMAQq_PMKQq_INTQq =>
   246.                case IO_opcode is
   247.                   when PMAQq_bits =>
   248.                      return "PMAQ" & q;
   249.                   when PMKQq_bits =>
   250.                      return "PMKQ" & q;
   251.                   when INTQq_bits =>
   252.                      return "INTQ" & q;
   253.                   when others =>
   254.                      return machine_code(decoded);
   255.                end case;
   256.
   257.             when CTQq_PMBQq_PMCQq_BUSYQq =>
   258.                case IO_opcode is
   259.                   when CTQq_bits =>
   260.                      if (decoded.Qk and manual_bit) /= 0 then
   261.                         return "MANUALQ" & q;
   262.                      else
   263.                         return "CTQ" & q;
   264.                      end if;
   265.                   when PMBQq_bits =>
   266.                      return "PMBQ" & q;
   267.                   when PMCQq_bits =>
   268.                      return "PMCQ" & q;
   269.                   when BUSYQq_bits =>
   270.                      return "BUSYQ" & q;
   271.                   when others =>
   272.                      return machine_code(decoded);
   273.                end case;
   274.
   275.             when PMDQq_PMEQq_PMLQq =>
   276.                case IO_opcode is
   277.                   when PMDQq_bits =>
   278.                      return "PMDQ" & q;
   279.                   when PMEQq_bits =>
   280.                      return "PMEQ" & q;
   281.                   when PMLQq_bits =>
   282.                      return "PMLQ" & q;
   283.                   when others =>
   284.                      return machine_code(decoded);
   285.                end case;
   286.
   287.             when PMFQq =>
   288.                return "PMFQ" & q;
   289.
   290.             when PMGQq =>
   291.                return "PMGQ" & q;
   292.
   293.             when PMHQq =>
   294.                return "PMHQ" & q;
   295.
   296.             when POAQq_POCQq_POEQq_POFQq =>
   297.                case IO_opcode is
   298.                   when POAQq_bits =>
   299.                      return "POAQ" & q;
   300.                   when POCQq_bits =>
   301.                      return "POCQ" & q;
   302.                   when POEQq_bits =>
   303.                      return "POEQ" & q;
   304.                   when POFQq_bits =>
   305.                      return "POFQ" & q;
   306.                   when others =>
   307.                      return machine_code(decoded);
   308.                end case;
   309.
   310.             when POBQq_PODQq =>
   311.                case IO_opcode is
   312.                   when POBQq_bits =>
   313.                      return "POBQ" & q;
   314.                   when PODQq_bits =>
   315.                      return "PODQ" & q;
   316.                   when others =>
   317.                      return machine_code(decoded);
   318.                end case;
   319.
   320.             when POGQq_POLQq =>
   321.                case IO_opcode is
   322.                   when POGQq_bits =>
   323.                      return "POGQ" & q;
   324.                   when POLQq_bits =>
   325.                      return "POLQ" & q;
   326.                   when others =>
   327.                      return machine_code(decoded);
   328.                end case;
   329.
   330.             when POHQq_POKQq =>
   331.                case IO_opcode is
   332.                   when POHQq_bits =>
   333.                      return "POHQ" & q;
   334.                   when POLQq_bits =>
   335.                      return "POKQ" & q;
   336.                   when others =>
   337.                      return machine_code(decoded);
   338.                end case;
   339.
   340.             when others =>
   341.                return machine_code(decoded);
   342.          end case;
   343.       end IO_order_name;
   344.
   345.    begin
   346.       case decoded.syndrome is
   347.          when JCqNZS =>
   348.             return "JC" & q & "NZS";
   349.          when MkMq =>
   350.             return "M" & k & "M" & q;
   351.          when MkMqQ =>
   352.             return "M" & k & "M" & q & "Q";
   353.          when MkMqH =>
   354.             return "M" & k & "M" & q & "H";
   355.          when MkMqQH =>
   356.             return "M" & k & "M" & q & "QH";
   357.          when MkMqN =>
   358.             return "M" & k & "M" & q & "N";
   359.          when MkMqQN =>
   360.             return "M" & k & "M" & q & "QN";
   361.          when MkMqHN =>
   362.             return "M" & k & "M" & q & "HN";
   363.          when MkMqQHN =>
   364.             return "M" & k & "M" & q & "QHN";
   365.          when TO_MkMq =>
   366.             return "=M" & k & "M" & q;
   367.          when TO_MkMqQ =>
   368.             return "=M" & k & "M" & q & "Q";
   369.          when TO_MkMqH =>
   370.             return "=M" & k & "M" & q & "H";
   371.          when TO_MkMqQH =>
   372.             return "=M" & k & "M" & q & "QH";
   373.          when TO_MkMqN =>
   374.             return "=M" & k & "M" & q & "N";
   375.          when TO_MkMqQN =>
   376.             return "=M" & k & "M" & q & "QN";
   377.          when TO_MkMqHN =>
   378.             return "=M" & k & "M" & q & "HN";
   379.          when TO_MkMqQHN =>
   380.             return "=M" & k & "M" & q & "QHN";
   381.          when M_PLUS_Iq =>
   382.             return "M+I" & q;
   383.          when M_MINUS_Iq =>
   384.             return "M-I" & q;
   385.          when NCq =>
   386.             return "NC" & q;
   387.          when DCq =>
   388.             return "DC" & q;
   389.          when POS1_TO_Iq =>
   390.             return "I" & q & "=+1";
   391.          when NEG1_TO_Iq =>
   392.             return "I" & q & "=-1";
   393.          when POS2_TO_Iq =>
   394.             return "I" & q & "=+2";
   395.          when NEG2_TO_Iq =>
   396.             return "I" & q & "=-2";
   397.          when MqTOQk =>
   398.             return "M"  & q & "TOQ" & k;
   399.          when IqTOQk =>
   400.             return "I"  & q & "TOQ" & k;
   401.          when IMqTOQk =>
   402.             return "IM" & q & "TOQ" & k;
   403.          when CqTOQk =>
   404.             return "C"  & q & "TOQ" & k;
   405.          when CMqTOQk =>
   406.             return "CM" & q & "TOQ" & k;
   407.          when CIqTOQk =>
   408.             return "CI" & q & "TOQ" & k;
   409.          when QqTOQk =>
   410.             return "Q"  & q & "TOQ" & k;
   411.          when QCIMq =>
   412.             if (decoded.Qk and all_Q_choice) = all_Q_choice then
   413.                return "Q" & q;
   414.             else
   415.                if (decoded.Qk and M_part_choice) /= 0 then
   416.                   return "M" & q;
   417.                elsif (decoded.Qk and C_part_choice) /= 0 then
   418.                   return "C" & q;
   419.                elsif (decoded.Qk and I_part_choice) /= 0 then
   420.                   return "I" & q;
   421.                else
   422.                   return machine_code(decoded);
   423.                end if;
   424.             end if;
   425.          when TO_RCIMq =>
   426.             if (decoded.Qk and all_Q_choice) = all_Q_choice then
   427.                return "=Q" & q;
   428.             else
   429.                if (decoded.Qk and M_part_choice) /= 0 then
   430.                   return optional((decoded.Qk and reset_choice) /= 0, "=RM" & q, "=M" & q);
   431.                elsif (decoded.Qk and C_part_choice) /= 0 then
   432.                   return optional((decoded.Qk and reset_choice) /= 0, "=RC" & q, "=C" & q);
   433.                elsif (decoded.Qk and I_part_choice) /= 0 then
   434.                   return optional((decoded.Qk and reset_choice) /= 0, "=RI" & q, "=I" & q);
   435.                else
   436.                   return machine_code(decoded);
   437.                end if;
   438.             end if;
   439.          when ADD_TO_QCIMq =>
   440.             if (decoded.Qk and all_Q_choice) = all_Q_choice then
   441.                return "=+Q" & q;
   442.             else
   443.                if (decoded.Qk and M_part_choice) /= 0 then
   444.                   return "=+M" & q;
   445.                elsif (decoded.Qk and C_part_choice) /= 0 then
   446.                   return "=+C" & q;
   447.                elsif (decoded.Qk and I_part_choice) /= 0 then
   448.                   return "=+I" & q;
   449.                else
   450.                   return machine_code(decoded);
   451.                end if;
   452.             end if;
   453.          when SHA =>
   454.             return "SHA"  & shift_count;
   455.          when SHAD =>
   456.             return "SHAD" & shift_count;
   457.          when MACC =>
   458.             return "×+"   & shift_count;
   459.          when SHL =>
   460.             return "SHL"  & shift_count;
   461.          when SHLD =>
   462.             return "SHLD" & shift_count;
   463.          when SHC =>
   464.             return "SHC"  & shift_count;
   465.          when TO_Kk =>
   466.             case decoded.Qq is
   467.                when K0 =>
   468.                   return "=K0";
   469.                when K1 =>
   470.                   return "=K1";
   471.                when K2 =>
   472.                   return "=K2";
   473.                when K3 =>
   474.                   return "=K3";
   475.                when others =>
   476.                   return machine_code(decoded);
   477.             end case;
   478.          when Kk =>
   479.             case decoded.Qk is
   480.                when K4 =>
   481.                   return "K4";
   482.                when K5 =>
   483.                   return "K5";
   484.                when K7 =>
   485.                   return "K7";
   486.                when others =>
   487.                   return machine_code(decoded);
   488.             end case;
   489.          when LINK =>
   490.             return "LINK";
   491.          when TO_LINK =>
   492.             return "=LINK";
   493.          when others =>
   494.             return IO_order_name(decoded);
   495.       end case;
   496.    end two_syllable_order_name;
   497.
   498.    function normal_jump_order_name (decoded      : KDF9.decoded_order;
   499.                                     octal_option : Boolean)
   500.    return String is
   501.       the_target  : code_point renames decoded.target;
   502.       the_address : constant String := oct_or_dec_of(the_target, octal_option);
   503.    begin
   504.       case decoded.syndrome is
   505.          when JrEQ =>
   506.             return "JE" & the_address & "EQ";
   507.          when JrGTZ =>
   508.             return "JE" & the_address & "GTZ";
   509.          when JrLTZ =>
   510.             return "JE" & the_address & "LTZ";
   511.          when JrEQZ =>
   512.             return "JE" & the_address & "EQZ";
   513.          when JrV =>
   514.             return "JE" & the_address & "V";
   515.          when JrEN =>
   516.             return "JE" & the_address & "EN";
   517.          when Jr =>
   518.             return "JE" & the_address;
   519.          when JrEJ =>
   520.             return "JE" & the_address & "EJ";
   521.          when JSr =>
   522.             return "JSE" & the_address;
   523.          when JrTR =>
   524.             return "JE" & the_address & "TR";
   525.          when EXIT_9 =>
   526.             if the_target.syllable_number = 0 then  -- c.f. decode_a_jump_order.
   527.                -- No halfword offset applies.
   528.                if the_target.word_number < 8 then
   529.                   if the_target.word_number = 0 then
   530.                      return "EXIT";
   531.                   else
   532.                      return "EXIT " & digit_map(KDF9.halfword(2*the_target.word_number));
   533.                   end if;
   534.                else
   535.                   return "EXITAE" & oct_or_dec_of((0, the_target.word_number), octal_option);
   536.                end if;
   537.             elsif the_target.word_number < 8 then
   538.                return "EXIT " & digit_map(KDF9.halfword(2*the_target.word_number + 1));
   539.             else
   540.                return "EXITAE" & oct_or_dec_of((3, the_target.word_number), octal_option);
   541.             end if;
   542.          when JrNE =>
   543.             return "JE" & the_address & "NE";
   544.          when JrLEZ =>
   545.             return "JE" & the_address & "LEZ";
   546.          when JrGEZ =>
   547.             return "JE" & the_address & "GEZ";
   548.          when JrNEZ =>
   549.             return "JE" & the_address & "NEZ";
   550.          when JrNV =>
   551.             return "JE" & the_address & "NV";
   552.          when JrNEN =>
   553.             return "JE" & the_address & "NEN";
   554.          when JrNEJ =>
   555.             return "JE" & the_address & "NEJ";
   556.          when JrNTR =>
   557.             return "JE" & the_address & "NTR";
   558.          when OUT_9 =>
   559.             return "OUT";
   560.          when EXITD =>
   561.             return "EXITD";
   562.          when JrCqZ =>
   563.             return "JE" & the_address
   564.                        & "C" & trimmed(KDF9.Q_number'Image(decoded.Qq)) & "Z";
   565.          when JrCqNZ =>
   566.             return "JE" & the_address
   567.                        & "C" & trimmed(KDF9.Q_number'Image(decoded.Qq)) & "NZ";
   568.          when others =>
   569.             return machine_code(decoded);
   570.       end case;
   571.    end normal_jump_order_name;
   572.
   573.    function data_access_order_name (decoded      : KDF9.decoded_order;
   574.                                     octal_option : Boolean)
   575.    return String is
   576.       operand     : KDF9.Q_part   renames decoded.operand;
   577.       Qq          : KDF9.Q_number renames decoded.Qq;
   578.       the_address : constant String
   579.                   := optional(octal_option,
   580.                               "#" & oct_of(operand),
   581.                               trimmed(KDF9.Q_part'Image(operand)));
   582.       the_Q_store : constant String
   583.                   := optional(Qq /= 0,
   584.                               "M" & trimmed(KDF9.Q_number'Image(Qq)));
   585.    begin
   586.       case decoded.syndrome is
   587.          when EaMq =>
   588.             return "E"  & the_address & the_Q_store;
   589.          when TO_EaMq =>
   590.             return "=E" & the_address & the_Q_store;
   591.          when EaMqQ =>
   592.             return "E"  & the_address & the_Q_store & "Q" ;
   593.          when TO_EaMqQ =>
   594.             return "=E" & the_address & the_Q_store & "Q" ;
   595.          when SET =>
   596.             return "SET " & optional(octal_option,"B" & oct_of(operand, 2), dec_of(operand));
   597.          when others =>
   598.             return machine_code(decoded);
   599.       end case;
   600.    end data_access_order_name;
   601.
   602.    function the_name_of (order : KDF9.decoded_order; octal_option : Boolean := True)
   603.    return String is
   604.    begin
   605.       case order.kind is
   606.          when one_syllable_order =>
   607.             return one_syllable_order_name(order);
   608.          when two_syllable_order =>
   609.             return two_syllable_order_name(order);
   610.          when normal_jump_order =>
   611.             return normal_jump_order_name(order, octal_option);
   612.          when data_access_order =>
   613.             return data_access_order_name(order, octal_option);
   614.       end case;
   615.    end the_name_of;
   616.
   617.    function the_order (order : KDF9.syllable_group; octal_option : Boolean)
   618.    return String is
   619.       its_INS : KDF9.decoded_order;
   620.    begin
   621.       its_INS.order := order;
   622.       decode(its_INS);
   623.       return the_name_of(its_INS, octal_option);
   624.    end the_order;
   625.
   626.    function the_order_at (address : KDF9.code_point; octal_option : Boolean)
   627.    return String is
   628.       saved_CIA : constant KDF9.code_point := CIA;
   629.       saved_NIA : constant KDF9.code_point := NIA;
   630.       saved_INS : constant KDF9.decoded_order := INS;
   631.    begin
   632.       set_NIA_to(address);
   633.       decode_the_next_order;
   634.       return result : constant String := the_name_of(INS, octal_option) do
   635.          CIA := saved_CIA;
   636.          set_NIA_to(saved_NIA);
   637.          INS := saved_INS;
   638.       end return;
   639.    end the_order_at;
   640.
   641.
   642.    function two_syllable_skeleton (encoding : KDF9.syllable)
   643.    return String is
   644.
   645.       function IO_skeleton (encoding : KDF9.syllable)
   646.       return String is
   647.       begin
   648.          case encoding and 8#77# is
   649.             when PARQq =>
   650.                return "PARQq";
   651.             when PIAQq_PICQq_CLOQq_TLOQq =>
   652.                return "{PIA|PIC|CLO|TLO}Qq";
   653.             when PIBQq_PIDQq =>
   654.                return "{PIB|PID}Qq";
   655.             when PIEQq_PIGQq =>
   656.                return "{PIE|PIG}Qq";
   657.             when PIFQq_PIHQq =>
   658.                return "{PIF|PIH}Qq";
   659.             when PMAQq_PMKQq_INTQq =>
   660.                return "{INT|PMA|PMK}Qq";
   661.             when CTQq_PMBQq_PMCQq_BUSYQq =>
   662.                return "{BUSY|CTQ|PMB|PMC}Qq";
   663.             when PMDQq_PMEQq_PMLQq =>
   664.                return "{PMD|PME}Qq";
   665.             when PMFQq =>
   666.                return "PMFQq";
   667.             when PMGQq =>
   668.                return "PMGQq";
   669.             when PMHQq =>
   670.                return "PMHQq";
   671.             when POAQq_POCQq_POEQq_POFQq =>
   672.                return "{POA|POC|POE|POF}Qq";
   673.             when POBQq_PODQq =>
   674.                return "{POB|POD}Qq";
   675.             when POGQq_POLQq =>
   676.                return "{POG|POL}Qq";
   677.             when POHQq_POKQq =>
   678.                return "{POH|POK}Qq";
   679.             when others =>
   680.                return "P??Qq";
   681.          end case;
   682.       end IO_skeleton;
   683.
   684.    begin
   685.       case encoding and 8#77# is
   686.          when JCqNZS =>
   687.             return "JCqNZS";
   688.          when MkMq =>
   689.             return "MkMq";
   690.          when MkMqQ =>
   691.             return "MkMqQ";
   692.          when MkMqH =>
   693.             return "MkMqH";
   694.          when MkMqQH =>
   695.             return "MkMqQH";
   696.          when MkMqN =>
   697.             return "MkMqN";
   698.          when MkMqQN =>
   699.             return "MkMqQN";
   700.          when MkMqHN =>
   701.             return "MkMqHN";
   702.          when MkMqQHN =>
   703.             return "MkMqQHN";
   704.          when TO_MkMq =>
   705.             return "=MkMq";
   706.          when TO_MkMqQ =>
   707.             return "=MkMqQ";
   708.          when TO_MkMqH =>
   709.             return "=MkMqH";
   710.          when TO_MkMqQH =>
   711.             return "=MkMqQH";
   712.          when TO_MkMqN =>
   713.             return "=MkMqN";
   714.          when TO_MkMqQN =>
   715.             return "=MkMqQN";
   716.          when TO_MkMqHN =>
   717.             return "=MkMqHN";
   718.          when TO_MkMqQHN =>
   719.             return "=MkMqQHN";
   720.          when M_PLUS_Iq =>
   721.             return "M+Iq";
   722.          when M_MINUS_Iq =>
   723.             return "M-Iq";
   724.          when NCq =>
   725.             return "NCq";
   726.          when DCq =>
   727.             return "DCq";
   728.          when POS1_TO_Iq =>
   729.             return "Iq=+1";
   730.          when NEG1_TO_Iq =>
   731.             return "Iq=-1";
   732.          when POS2_TO_Iq =>
   733.             return "Iq=+2";
   734.          when NEG2_TO_Iq =>
   735.             return "Iq=-2";
   736.          when MqTOQk =>
   737.             return "MqTOQk";
   738.          when IqTOQk =>
   739.             return "IqTOQk";
   740.          when IMqTOQk =>
   741.             return "IMqTOQk";
   742.          when CqTOQk =>
   743.             return "CqTOQk";
   744.          when CMqTOQk =>
   745.             return "CMqTOQk";
   746.          when CIqTOQk =>
   747.             return "CIqTOQk";
   748.          when QqTOQk =>
   749.             return "QqTOQk";
   750.          when QCIMq =>
   751.             return "{Q|C|I|M}q";
   752.          when TO_RCIMq =>
   753.             return "=[R]{Q|C|I|M}q";
   754.          when ADD_TO_QCIMq =>
   755.             return "=+{Q|C|I|M}q";
   756.          when SHA =>
   757.             return "SHA";
   758.          when SHAD =>
   759.             return "SHAD";
   760.          when MACC =>
   761.             return "×+";
   762.          when SHL =>
   763.             return "SHL";
   764.          when SHLD =>
   765.             return "SHLD";
   766.          when SHC =>
   767.             return "SHC";
   768.          when TO_Kk =>
   769.             case encoding mod 16 is
   770.                when K0 =>
   771.                   return "=K0";
   772.                when K1 =>
   773.                   return "=K1";
   774.                when K2 =>
   775.                   return "=K2";
   776.                when K3 =>
   777.                   return "=K3";
   778.                when others =>
   779.                   return "=K?";
   780.             end case;
   781.          when Kk =>
   782.             case encoding mod 16 is
   783.                when K4 =>
   784.                   return "K4";
   785.                when K5 =>
   786.                   return "K5";
   787.                when K7 =>
   788.                   return "K7";
   789.                when others =>
   790.                   return "K?";
   791.             end case;
   792.          when LINK =>
   793.             return "LINK";
   794.          when TO_LINK =>
   795.             return "=LINK";
   796.          when others =>
   797.             return IO_skeleton (encoding);
   798.       end case;
   799.    end two_syllable_skeleton;
   800.
   801.    function normal_jump_skeleton (encoding : KDF9.syllable)
   802.    return String is
   803.    begin
   804.       case encoding and 8#77# is
   805.          when JrEQ =>
   806.             return "JrEQ";
   807.          when JrGTZ =>
   808.             return "JrGTZ";
   809.          when JrLTZ =>
   810.             return "JrLTZ";
   811.          when JrEQZ =>
   812.             return "JrEQZ";
   813.          when JrV =>
   814.             return "JrV";
   815.          when JrEN =>
   816.             return "JrEN";
   817.          when Jr =>
   818.             return "Jr";
   819.          when JrEJ =>
   820.             return "JrEJ";
   821.          when JSr =>
   822.             return "JSr";
   823.          when JrTR =>
   824.             return "JrTR";
   825.          when EXIT_9 =>
   826.             return "EXIT";
   827.          when JrNE =>
   828.             return "JrNE";
   829.          when JrLEZ =>
   830.             return "JrLEZ";
   831.          when JrGEZ =>
   832.             return "JrGEZ";
   833.          when JrNEZ =>
   834.             return "JrNEZ";
   835.          when JrNV =>
   836.             return "JrNV";
   837.          when JrNEN =>
   838.             return "JrNEN";
   839.          when JrNEJ =>
   840.             return "JrNEJ";
   841.          when JrNTR =>
   842.             return "JrNTR";
   843.          when OUT_9 =>
   844.             return "OUT";
   845.          when EXITD =>
   846.             return "EXITD";
   847.          when JrCqZ .. JrCqZ+2#1111# =>
   848.             return "JrCqZ";
   849.          when JrCqNZ .. JrCqNZ+2#1111# =>
   850.             return "JrCqNZ";
   851.          when others =>
   852.             return "Jr?";
   853.       end case;
   854.    end normal_jump_skeleton;
   855.
   856.    function data_access_skeleton (decoded : KDF9.decoded_order)
   857.    return String is
   858.    begin
   859.       case decoded.syndrome is
   860.          when EaMq =>
   861.             return "EeMq";
   862.          when TO_EaMq =>
   863.             return "=EeMq";
   864.          when EaMqQ =>
   865.             return "EeMqQ";
   866.          when TO_EaMqQ =>
   867.             return "=EeMqQ";
   868.          when SET =>
   869.             return "SET";
   870.          when others =>
   871.             return machine_code(decoded);
   872.       end case;
   873.    end data_access_skeleton;
   874.
   875.    function the_skeleton_order (syllable_0 : KDF9.syllable)
   876.    return String is
   877.       its_INS : KDF9.decoded_order;
   878.    begin
   879.       its_INS.order := (syllable_0, 0, 0);
   880.       case KDF9.INS_kind(syllable_0 / 2**6) is
   881.          when one_syllable_order =>
   882.             decode(its_INS);
   883.             return one_syllable_order_name(its_INS);
   884.          when two_syllable_order =>
   885.             return two_syllable_skeleton(syllable_0);
   886.          when normal_jump_order =>
   887.             return normal_jump_skeleton(syllable_0);
   888.          when data_access_order =>
   889.             decode(its_INS);
   890.             return data_access_skeleton(its_INS);
   891.       end case;
   892.    end the_skeleton_order;
   893.
   894. end disassembly;

Compiling: ../Source\disassembly.ads
Source file time stamp: 2015-06-18 00:57:00
Compiled at: 2015-10-28 18:14:59

     1. -- disassembly.ads
     2. --
     3. -- Produce dis-assembled instructions in an approximation to KDF9 Usercode.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9;
    20.
    21. use  KDF9;
    22.
    23. package disassembly is
    24.
    25.    pragma Unsuppress(All_Checks);
    26.
    27.    function machine_code (decoded : KDF9.decoded_order)
    28.    return String;
    29.
    30.    function one_syllable_order_name (decoded : KDF9.decoded_order)
    31.    return String;
    32.
    33.    function two_syllable_order_name (decoded : KDF9.decoded_order)
    34.    return String;
    35.
    36.    function normal_jump_order_name (decoded      : KDF9.decoded_order;
    37.                                     octal_option : Boolean)
    38.    return String;
    39.
    40.    function data_access_order_name (decoded      : KDF9.decoded_order;
    41.                                     octal_option : Boolean)
    42.    return String;
    43.
    44.    function the_name_of (order : KDF9.decoded_order; octal_option : Boolean := True)
    45.    return String;
    46.
    47.    function the_order (order : KDF9.syllable_group; octal_option : Boolean)
    48.    return String;
    49.
    50.    function the_order_at (address : KDF9.code_point; octal_option : Boolean)
    51.    return String;
    52.
    53.    function the_skeleton_order (syllable_0 : KDF9.syllable)
    54.    return String;
    55.
    56. end disassembly;

 894 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\kdf9-compressed_opcodes.ads
Source file time stamp: 2015-06-18 00:56:14
Compiled at: 2015-10-28 18:15:08

     1. -- kdf9-compressed_opcodes.ads
     2. --
     3. -- The "syndrome" values are effective opcodes, partially decoded from the first syllable,
     4. --   and compressed with opcode bits of the second syllable, where appropriate (e.g. in jumps).
     5. --
     6. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     7. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     8. --
     9. -- The ee9 program is free software; you can redistribute it and/or
    10. -- modify it under terms of the GNU General Public License as published
    11. -- by the Free Software Foundation; either version 3, or (at your option)
    12. -- any later version. This program is distributed in the hope that it
    13. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    14. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    15. -- See the GNU General Public License for more details. You should have
    16. -- received a copy of the GNU General Public License distributed with
    17. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    18. --
    19.
    20. package KDF9.compressed_opcodes is
    21.
    22.       --
    23.       -- The syndrome values for 1-syllable orders are equal to their full codes.
    24.       --
    25.
    26.       ALL_0    : constant KDF9.syndrome := 2#000_000#;
    27.       VR       : constant KDF9.syndrome := 2#000_001#;
    28.       TO_TR    : constant KDF9.syndrome := 2#000_010#;
    29.       BITS     : constant KDF9.syndrome := 2#000_011#;
    30.       XF       : constant KDF9.syndrome := 2#000_100#;
    31.       XDF      : constant KDF9.syndrome := 2#000_101#;
    32.       INV006   : constant KDF9.syndrome := 2#000_110#;
    33.       XPLUSF   : constant KDF9.syndrome := 2#000_111#;
    34.       NEGD     : constant KDF9.syndrome := 2#001_000#;
    35.       OR_9     : constant KDF9.syndrome := 2#001_001#;
    36.       PERM     : constant KDF9.syndrome := 2#001_010#;
    37.       TOB      : constant KDF9.syndrome := 2#001_011#;
    38.       ROUNDH   : constant KDF9.syndrome := 2#001_100#;
    39.       NEV      : constant KDF9.syndrome := 2#001_101#;
    40.       ROUND    : constant KDF9.syndrome := 2#001_110#;
    41.       DUMMY    : constant KDF9.syndrome := 2#001_111#;
    42.       ROUNDF   : constant KDF9.syndrome := 2#010_000#;
    43.       ROUNDHF  : constant KDF9.syndrome := 2#010_001#;
    44.       MINUSDF  : constant KDF9.syndrome := 2#010_010#;
    45.       PLUSDF   : constant KDF9.syndrome := 2#010_011#;
    46.       FLOAT_9  : constant KDF9.syndrome := 2#010_100#;
    47.       FLOATD   : constant KDF9.syndrome := 2#010_101#;
    48.       ABS_9    : constant KDF9.syndrome := 2#010_110#;
    49.       NEG      : constant KDF9.syndrome := 2#010_111#;
    50.       ABSF     : constant KDF9.syndrome := 2#011_000#;
    51.       NEGF     : constant KDF9.syndrome := 2#011_001#;
    52.       MAX      : constant KDF9.syndrome := 2#011_010#;
    53.       NOT_9    : constant KDF9.syndrome := 2#011_011#;
    54.       XD       : constant KDF9.syndrome := 2#011_100#;
    55.       X_frac   : constant KDF9.syndrome := 2#011_101#;
    56.       MINUS    : constant KDF9.syndrome := 2#011_110#;
    57.       SIGN     : constant KDF9.syndrome := 2#011_111#;
    58.       INV040   : constant KDF9.syndrome := 2#100_000#;
    59.       ZERO     : constant KDF9.syndrome := 2#100_001#;
    60.       DUP      : constant KDF9.syndrome := 2#100_010#;
    61.       DUPD     : constant KDF9.syndrome := 2#100_011#;
    62.       DIVI     : constant KDF9.syndrome := 2#100_100#;
    63.       FIX      : constant KDF9.syndrome := 2#100_101#;
    64.       INV046   : constant KDF9.syndrome := 2#100_110#;
    65.       STR      : constant KDF9.syndrome := 2#100_111#;
    66.       CONT     : constant KDF9.syndrome := 2#101_000#;
    67.       REVD     : constant KDF9.syndrome := 2#101_001#;
    68.       ERASE    : constant KDF9.syndrome := 2#101_010#;
    69.       MINUSD   : constant KDF9.syndrome := 2#101_011#;
    70.       AND_9    : constant KDF9.syndrome := 2#101_100#;
    71.       INV055   : constant KDF9.syndrome := 2#101_101#;
    72.       PLUS     : constant KDF9.syndrome := 2#101_110#;
    73.       PLUSD    : constant KDF9.syndrome := 2#101_111#;
    74.       DIV      : constant KDF9.syndrome := 2#110_000#;
    75.       DIVD     : constant KDF9.syndrome := 2#110_001#;
    76.       DIVF     : constant KDF9.syndrome := 2#110_010#;
    77.       DIVDF    : constant KDF9.syndrome := 2#110_011#;
    78.       DIVR     : constant KDF9.syndrome := 2#110_100#;
    79.       REV      : constant KDF9.syndrome := 2#110_101#;
    80.       CAB      : constant KDF9.syndrome := 2#110_110#;
    81.       FRB      : constant KDF9.syndrome := 2#110_111#;
    82.       STAND    : constant KDF9.syndrome := 2#111_000#;
    83.       NEGDF    : constant KDF9.syndrome := 2#111_001#;
    84.       MAXF     : constant KDF9.syndrome := 2#111_010#;
    85.       INV073   : constant KDF9.syndrome := 2#111_011#;
    86.       PLUSF    : constant KDF9.syndrome := 2#111_100#;
    87.       MINUSF   : constant KDF9.syndrome := 2#111_101#;
    88.       INV076   : constant KDF9.syndrome := 2#111_110#;
    89.       SIGNF    : constant KDF9.syndrome := 2#111_111#;
    90.
    91.       --
    92.       -- Syndrome Values For 2-Syllable Orders
    93.       --
    94.
    95.       -- syndrome values for 2-syllable indirect fetch and store orders
    96.
    97.       MkMq       : constant KDF9.syndrome := 2#000_000#;
    98.       MkMqQ      : constant KDF9.syndrome := 2#000_010#;
    99.       MkMqH      : constant KDF9.syndrome := 2#000_100#;
   100.       MkMqQH     : constant KDF9.syndrome := 2#000_110#;
   101.       MkMqN      : constant KDF9.syndrome := 2#001_000#;
   102.       MkMqQN     : constant KDF9.syndrome := 2#001_010#;
   103.       MkMqHN     : constant KDF9.syndrome := 2#001_100#;
   104.       MkMqQHN    : constant KDF9.syndrome := 2#001_110#;
   105.       TO_MkMq    : constant KDF9.syndrome := 2#000_001#;
   106.       TO_MkMqQ   : constant KDF9.syndrome := 2#000_011#;
   107.       TO_MkMqH   : constant KDF9.syndrome := 2#000_101#;
   108.       TO_MkMqQH  : constant KDF9.syndrome := 2#000_111#;
   109.       TO_MkMqN   : constant KDF9.syndrome := 2#001_001#;
   110.       TO_MkMqQN  : constant KDF9.syndrome := 2#001_011#;
   111.       TO_MkMqHN  : constant KDF9.syndrome := 2#001_101#;
   112.       TO_MkMqQHN : constant KDF9.syndrome := 2#001_111#;
   113.
   114.       -- syndrome values for 2-syllable Q store orders
   115.
   116.       M_PLUS_Iq    : constant KDF9.syndrome := 2#100_000#;
   117.       M_MINUS_Iq   : constant KDF9.syndrome := 2#100_001#;
   118.       NCq          : constant KDF9.syndrome := 2#100_010#;
   119.       DCq          : constant KDF9.syndrome := 2#100_011#;
   120.       POS1_TO_Iq   : constant KDF9.syndrome := 2#100_100#;
   121.       NEG1_TO_Iq   : constant KDF9.syndrome := 2#100_101#;
   122.       POS2_TO_Iq   : constant KDF9.syndrome := 2#100_110#;
   123.       NEG2_TO_Iq   : constant KDF9.syndrome := 2#100_111#;
   124.       MqTOQk       : constant KDF9.syndrome := 2#101_001#;
   125.       IqTOQk       : constant KDF9.syndrome := 2#101_010#;
   126.       IMqTOQk      : constant KDF9.syndrome := 2#101_011#;
   127.       CqTOQk       : constant KDF9.syndrome := 2#101_100#;
   128.       CMqTOQk      : constant KDF9.syndrome := 2#101_101#;
   129.       CIqTOQk      : constant KDF9.syndrome := 2#101_110#;
   130.       QqTOQk       : constant KDF9.syndrome := 2#101_111#;
   131.       SHA          : constant KDF9.syndrome := 2#110_001#;
   132.       SHAD         : constant KDF9.syndrome := 2#110_010#;
   133.       MACC         : constant KDF9.syndrome := 2#110_011#;
   134.       SHL          : constant KDF9.syndrome := 2#110_100#;
   135.       SHLD         : constant KDF9.syndrome := 2#110_110#;
   136.       SHC          : constant KDF9.syndrome := 2#110_111#;
   137.       TO_RCIMq     : constant KDF9.syndrome := 2#111_000#;
   138.       QCIMq        : constant KDF9.syndrome := 2#111_001#;
   139.       ADD_TO_QCIMq : constant KDF9.syndrome := 2#111_010#;
   140.
   141.       -- masks for Q store Qk bits
   142.
   143.       reset_choice  : constant := 2#0001#;
   144.       C_part_choice : constant := 2#1000#;
   145.       I_part_choice : constant := 2#0100#;
   146.       M_part_choice : constant := 2#0010#;
   147.       all_Q_choice  : constant := C_part_choice + I_part_choice + M_part_choice;
   148.
   149.       -- syndrome values for 2-syllable SJNS orders
   150.
   151.       LINK    : constant KDF9.syndrome := 2#111_011#;
   152.       TO_LINK : constant KDF9.syndrome := 2#111_100#;
   153.
   154.       -- syndrome values for 2-syllable Director-only orders
   155.
   156.       TO_Kk : constant KDF9.syndrome := 2#111_101#;
   157.       K0    : constant := 2#1000#;
   158.       K1    : constant := 2#0100#;
   159.       K2    : constant := 2#0010#;
   160.       K3    : constant := 2#0001#;
   161.       Kk    : constant KDF9.syndrome := 2#111_110#;
   162.       K4    : constant := 2#1000#;
   163.       K5    : constant := 2#0100#;
   164.       K7    : constant := 2#0001#;
   165.
   166.       -- syndrome value for 2-syllable short-loop jump order
   167.
   168.       JCqNZS : constant KDF9.syndrome := 2#111_111#;
   169.
   170.       -- syndrome values for 2-syllable I/O orders
   171.
   172.       PARQq                   : constant KDF9.syndrome := 2#010_001#;
   173.       PIAQq_PICQq_CLOQq_TLOQq : constant KDF9.syndrome := 2#010_100#;
   174.       PIBQq_PIDQq             : constant KDF9.syndrome := 2#010_101#;
   175.       PIEQq_PIGQq             : constant KDF9.syndrome := 2#010_110#;
   176.       PIFQq_PIHQq             : constant KDF9.syndrome := 2#010_111#;
   177.
   178.       PMAQq_PMKQq_INTQq       : constant KDF9.syndrome := 2#011_100#;
   179.       CTQq_PMBQq_PMCQq_BUSYQq : constant KDF9.syndrome := 2#010_000#;
   180.       PMDQq_PMEQq_PMLQq       : constant KDF9.syndrome := 2#011_110#;
   181.       PMFQq                   : constant KDF9.syndrome := 2#010_010#;
   182.       PMGQq                   : constant KDF9.syndrome := 2#011_101#;  -- ??
   183.       PMHQq                   : constant KDF9.syndrome := 2#011_111#;  -- "SLOQq"
   184.
   185.       POAQq_POCQq_POEQq_POFQq : constant KDF9.syndrome := 2#011_000#;
   186.       POBQq_PODQq             : constant KDF9.syndrome := 2#011_001#;
   187.       POGQq_POLQq             : constant KDF9.syndrome := 2#011_010#;
   188.       POHQq_POKQq             : constant KDF9.syndrome := 2#011_011#;
   189.
   190.       -- masks for I/O opcode extension bits (Qk field)
   191.
   192.       PARQq_bits  : constant := 2#0000#;
   193.
   194.       -- PIAQq_PICQq_CLOQq_TLOQq:
   195.       PIAQq_bits  : constant := 2#0000#;
   196.       PICQq_bits  : constant := 2#1000#;
   197.       CLOQq_bits  : constant := 2#0010#;
   198.       TLOQq_bits  : constant := 2#0100#;
   199.
   200.       -- PIBQq_PIDQq:
   201.       PIBQq_bits  : constant := 2#0000#;
   202.       PIDQq_bits  : constant := 2#1000#;
   203.
   204.       -- PIEQq_PIGQq:
   205.       PIEQq_bits  : constant := 2#0000#;
   206.       PIGQq_bits  : constant := 2#1000#;
   207.
   208.       -- PIFQq_PIHQq:
   209.       PIFQq_bits  : constant := 2#0000#;
   210.       PIHQq_bits  : constant := 2#1000#;
   211.
   212.       -- PMAQq_PMKQq_INTQq:
   213.       PMAQq_bits  : constant := 2#0000#;
   214.       PMKQq_bits  : constant := 2#0100#;
   215.       INTQq_bits  : constant := 2#0010#;
   216.
   217.       -- CTQq_PMBQq_PMCQq_BUSYQq:
   218.       CTQq_bits   : constant := 2#0000#;
   219.       PMBQq_bits  : constant := 2#1000#;
   220.       PMCQq_bits  : constant := 2#0100#;
   221.       BUSYQq_bits : constant := 2#0010#;
   222.       manual_bit  : constant := 2#0001#;
   223.
   224.       -- PMDQq_PMEQq_PMLQq:
   225.       PMEQq_bits  : constant := 2#0000#;
   226.       PMDQq_bits  : constant := 2#1000#;
   227.       PMLQq_bits  : constant := 2#0100#;
   228.
   229.       -- PMFQq:
   230.       PMFQq_bits  : constant := 2#0000#;
   231.
   232.       -- PMGQq:
   233.       PMGQq_bits  : constant := 2#0000#;  -- ??
   234.
   235.       -- PMFQq:
   236.       PMHQq_bits  : constant := 2#0000#;
   237.
   238.       -- POAQq_POCQq_POEQq_POFQq:
   239.       POAQq_bits  : constant := 2#0000#;
   240.       POCQq_bits  : constant := 2#1000#;
   241.       POEQq_bits  : constant := 2#1100#;
   242.       POFQq_bits  : constant := 2#0100#;
   243.
   244.       -- POBQq_PODQq:
   245.       POBQq_bits  : constant := 2#0000#;
   246.       PODQq_bits  : constant := 2#1000#;
   247.
   248.       -- POGQq_POLQq:
   249.       POGQq_bits  : constant := 2#0000#;
   250.       POLQq_bits  : constant := 2#1000#;
   251.
   252.       -- POHQq_POKQq:
   253.       POHQq_bits  : constant := 2#0000#;
   254.       POKQq_bits  : constant := 2#1000#;
   255.
   256.       this_op_uses_2_Q_stores : constant array (KDF9.syndrome) of Boolean
   257.                               := (
   258.                                    MkMq
   259.                                  | MkMqQ
   260.                                  | MkMqH
   261.                                  | MkMqQH
   262.                                  | MkMqN
   263.                                  | MkMqQN
   264.                                  | MkMqHN
   265.                                  | MkMqQHN
   266.                                  | TO_MkMq
   267.                                  | TO_MkMqQ
   268.                                  | TO_MkMqH
   269.                                  | TO_MkMqQH
   270.                                  | TO_MkMqN
   271.                                  | TO_MkMqQN
   272.                                  | TO_MkMqHN
   273.                                  | TO_MkMqQHN
   274.                                  | MqTOQk
   275.                                  | IqTOQk
   276.                                  | IMqTOQk
   277.                                  | CqTOQk
   278.                                  | CMqTOQk
   279.                                  | CIqTOQk
   280.                                  | QqTOQk    => True,
   281.                                    others    => False
   282.                                  );
   283.
   284.
   285.       --
   286.       -- Syndrome Values For 3-Syllable Orders
   287.       --
   288.
   289.       -- syndrome values for normal jump orders
   290.
   291.       JrNE   : constant KDF9.syndrome := 2#000_001#;
   292.       JrGEZ  : constant KDF9.syndrome := 2#000_010#;
   293.       JrLEZ  : constant KDF9.syndrome := 2#000_100#;
   294.       JrNEZ  : constant KDF9.syndrome := 2#000_110#;
   295.       JrNV   : constant KDF9.syndrome := 2#001_000#;
   296.       OUT_9  : constant KDF9.syndrome := 2#001_001#;
   297.       JrNEN  : constant KDF9.syndrome := 2#001_010#;
   298.       Jr     : constant KDF9.syndrome := 2#001_011#;
   299.       JrNEJ  : constant KDF9.syndrome := 2#001_100#;
   300.       JSr    : constant KDF9.syndrome := 2#001_101#;
   301.       JrNTR  : constant KDF9.syndrome := 2#001_110#;
   302.       EXIT_9 : constant KDF9.syndrome := 2#001_111#;  -- 0h0 in bits 5-7
   303.       JrEQ   : constant KDF9.syndrome := 2#010_001#;
   304.       JrLTZ  : constant KDF9.syndrome := 2#010_010#;
   305.       JrGTZ  : constant KDF9.syndrome := 2#010_100#;
   306.       JrEQZ  : constant KDF9.syndrome := 2#010_110#;
   307.       JrV    : constant KDF9.syndrome := 2#011_000#;
   308.       JrEN   : constant KDF9.syndrome := 2#011_010#;
   309.       JrEJ   : constant KDF9.syndrome := 2#011_100#;
   310.       JrTR   : constant KDF9.syndrome := 2#011_110#;
   311.       EXITD  : constant KDF9.syndrome := 2#011_111#;  -- 010 in bits 5-7
   312.       JrCqZ  : constant KDF9.syndrome := 2#100_000#;
   313.       JrCqNZ : constant KDF9.syndrome := 2#110_000#;
   314.
   315.       EXIT_1_bit : constant := 2#010#;  -- 0h0 in bits 5-7 of EXIT syllable_0
   316.
   317.       -- syndrome values for directly-addressed data access orders
   318.
   319.       EaMq     : constant KDF9.syndrome := 2#000_000#;
   320.       TO_EaMq  : constant KDF9.syndrome := 2#000_001#;
   321.       EaMqQ    : constant KDF9.syndrome := 2#000_010#;
   322.       TO_EaMqQ : constant KDF9.syndrome := 2#000_011#;
   323.       SET      : constant KDF9.syndrome := 2#000_100#;
   324.
   325. end KDF9.compressed_opcodes;

 325 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\ioc-assignment.adb
Source file time stamp: 2015-06-18 00:56:38
Compiled at: 2015-10-28 18:15:09

     1. -- ioc-assignment.adb
     2. --
     3. -- CPU I/O orders are assigned here to device-specific buffers within IOC.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9.PHU_store;
    20. with KDF9.store;
    21. with tracing;
    22.
    23. use  tracing;
    24.
    25. package body IOC.assignment is
    26.
    27.    pragma Unsuppress(All_Checks);
    28.
    29.
    30.    --
    31.    -- CLO, SLO and TLO do not operate on a buffer, and so can be fully implemented here.
    32.    --
    33.
    34.    procedure CLO (Q_operand   : in KDF9.Q_register;
    35.                   set_offline : in Boolean) is
    36.       pragma Unreferenced(set_offline);
    37.       use  KDF9.PHU_store;
    38.    begin
    39.       take_note_of(Q_operand);
    40.       KDF9.store.clear_lockouts(Q_operand);
    41.       -- CLO also clears PHU[CPL].
    42.       PHU(CPL) := idle_PHU;
    43.       add_in_the_IO_lockout_CPU_time(Q_operand);
    44.    end CLO;
    45.
    46.    procedure SLO (Q_operand   : in KDF9.Q_register;
    47.                   set_offline : in Boolean) is
    48.       pragma Unreferenced(set_offline);
    49.    begin
    50.       take_note_of(Q_operand);
    51.       KDF9.store.set_lockouts(Q_operand);
    52.       add_in_the_IO_lockout_CPU_time(Q_operand);
    53.    end SLO;
    54.
    55.    procedure TLO (Q_operand   : in KDF9.Q_register;
    56.                   result      : out KDF9.word) is
    57.    begin
    58.       result := KDF9.store.test_lockouts(Q_operand);
    59.       take_note_of(Q_operand, status => result);
    60.       add_in_the_IO_lockout_CPU_time(Q_operand);
    61.    end TLO;
    62.
    63.    --
    64.    -- All other I/O orders do access a buffer, and so dispatch.
    65.    --
    66.
    67.    procedure BUSY (Q_operand   : in KDF9.Q_register;
    68.                    set_offline : in Boolean;
    69.                    result      : out KDF9.word) is
    70.    begin
    71.       buffer(Q_operand.C and buffer_number_mask).BUSY(Q_operand, set_offline, result);
    72.    end BUSY;
    73.
    74.    procedure PAR (Q_operand   : in KDF9.Q_register;
    75.                   set_offline : in Boolean;
    76.                   result      : out KDF9.word) is
    77.    begin
    78.       buffer(Q_operand.C and buffer_number_mask).PAR(Q_operand, set_offline, result);
    79.    end PAR;
    80.
    81.    procedure CTQ (Q_operand   : in KDF9.Q_register;
    82.                   set_offline : in Boolean) is
    83.    begin
    84.       buffer(Q_operand.C and buffer_number_mask).CTQ(Q_operand, set_offline);
    85.    end CTQ;
    86.
    87.    procedure INT (Q_operand   : in KDF9.Q_register;
    88.                   set_offline : in Boolean) is
    89.    begin
    90.       buffer(Q_operand.C and buffer_number_mask).INT(Q_operand, set_offline);
    91.    end INT;
    92.
    93.    procedure PIA (Q_operand   : in KDF9.Q_register;
    94.                   set_offline : in Boolean) is
    95.    begin
    96.       buffer(Q_operand.C and buffer_number_mask).PIA(Q_operand, set_offline);
    97.       add_in_the_IO_lockout_CPU_time(Q_operand);
    98.    end PIA;
    99.
   100.    procedure PIB (Q_operand   : in KDF9.Q_register;
   101.                   set_offline : in Boolean) is
   102.    begin
   103.       buffer(Q_operand.C and buffer_number_mask).PIB(Q_operand, set_offline);
   104.       add_in_the_IO_lockout_CPU_time(Q_operand);
   105.    end PIB;
   106.
   107.    procedure PIC (Q_operand   : in KDF9.Q_register;
   108.                   set_offline : in Boolean) is
   109.    begin
   110.       buffer(Q_operand.C and buffer_number_mask).PIC(Q_operand, set_offline);
   111.       add_in_the_IO_lockout_CPU_time(Q_operand);
   112.    end PIC;
   113.
   114.    procedure PID (Q_operand   : in KDF9.Q_register;
   115.                   set_offline : in Boolean) is
   116.    begin
   117.       buffer(Q_operand.C and buffer_number_mask).PID(Q_operand, set_offline);
   118.       add_in_the_IO_lockout_CPU_time(Q_operand);
   119.    end PID;
   120.
   121.    procedure PIE (Q_operand   : in KDF9.Q_register;
   122.                   set_offline : in Boolean) is
   123.    begin
   124.       buffer(Q_operand.C and buffer_number_mask).PIE(Q_operand, set_offline);
   125.       add_in_the_IO_lockout_CPU_time(Q_operand);
   126.    end PIE;
   127.
   128.    procedure PIF (Q_operand   : in KDF9.Q_register;
   129.                   set_offline : in Boolean) is
   130.    begin
   131.       buffer(Q_operand.C and buffer_number_mask).PIF(Q_operand, set_offline);
   132.       add_in_the_IO_lockout_CPU_time(Q_operand);
   133.    end PIF;
   134.
   135.    procedure PIG (Q_operand   : in KDF9.Q_register;
   136.                   set_offline : in Boolean) is
   137.    begin
   138.       buffer(Q_operand.C and buffer_number_mask).PIG(Q_operand, set_offline);
   139.       add_in_the_IO_lockout_CPU_time(Q_operand);
   140.    end PIG;
   141.
   142.    procedure PIH (Q_operand   : in KDF9.Q_register;
   143.                   set_offline : in Boolean) is
   144.    begin
   145.       buffer(Q_operand.C and buffer_number_mask).PIH(Q_operand, set_offline);
   146.       add_in_the_IO_lockout_CPU_time(Q_operand);
   147.    end PIH;
   148.
   149.    procedure PMA (Q_operand   : in KDF9.Q_register;
   150.                   set_offline : in Boolean) is
   151.    begin
   152.       buffer(Q_operand.C and buffer_number_mask).PMA(Q_operand, set_offline);
   153.    end PMA;
   154.
   155.    procedure PMB (Q_operand   : in KDF9.Q_register;
   156.                   set_offline : in Boolean) is
   157.    begin
   158.       buffer(Q_operand.C and buffer_number_mask).PMB(Q_operand, set_offline);
   159.    end PMB;
   160.
   161.    procedure PMC (Q_operand   : in KDF9.Q_register;
   162.                   set_offline : in Boolean) is
   163.    begin
   164.       buffer(Q_operand.C and buffer_number_mask).PMC(Q_operand, set_offline);
   165.    end PMC;
   166.
   167.    procedure PMD (Q_operand   : in KDF9.Q_register;
   168.                   set_offline : in Boolean) is
   169.    begin
   170.       buffer(Q_operand.C and buffer_number_mask).PMD(Q_operand, set_offline);
   171.    end PMD;
   172.
   173.    procedure PME (Q_operand   : in KDF9.Q_register;
   174.                   set_offline : in Boolean) is
   175.    begin
   176.       buffer(Q_operand.C and buffer_number_mask).PME(Q_operand, set_offline);
   177.    end PME;
   178.
   179.    procedure PMF (Q_operand   : in KDF9.Q_register;
   180.                   set_offline : in Boolean) is
   181.    begin
   182.       buffer(Q_operand.C and buffer_number_mask).PMF(Q_operand, set_offline);
   183.    end PMF;
   184.
   185.    procedure PMG (Q_operand   : in KDF9.Q_register;
   186.                   set_offline : in Boolean) is
   187.    begin
   188.       buffer(Q_operand.C and buffer_number_mask).PMG(Q_operand, set_offline);
   189.    end PMG;
   190.
   191.    procedure PMH (Q_operand   : in KDF9.Q_register;
   192.                   set_offline : in Boolean) is
   193.    begin
   194.       buffer(Q_operand.C and buffer_number_mask).PMH(Q_operand, set_offline);
   195.       add_in_the_IO_lockout_CPU_time(Q_operand);
   196.    end PMH;
   197.
   198.    procedure PMK (Q_operand   : in KDF9.Q_register;
   199.                   set_offline : in Boolean) is
   200.    begin
   201.       buffer(Q_operand.C and buffer_number_mask).PMK(Q_operand, set_offline);
   202.    end PMK;
   203.
   204.    procedure PML (Q_operand   : in KDF9.Q_register;
   205.                   set_offline : in Boolean) is
   206.    begin
   207.       buffer(Q_operand.C and buffer_number_mask).PML(Q_operand, set_offline);
   208.    end PML;
   209.
   210.    procedure POA (Q_operand   : in KDF9.Q_register;
   211.                   set_offline : in Boolean) is
   212.    begin
   213.       buffer(Q_operand.C and buffer_number_mask).POA(Q_operand, set_offline);
   214.       add_in_the_IO_lockout_CPU_time(Q_operand);
   215.    end POA;
   216.
   217.    procedure POB (Q_operand   : in KDF9.Q_register;
   218.                   set_offline : in Boolean) is
   219.    begin
   220.       buffer(Q_operand.C and buffer_number_mask).POB(Q_operand, set_offline);
   221.       add_in_the_IO_lockout_CPU_time(Q_operand);
   222.    end POB;
   223.
   224.    procedure POC (Q_operand   : in KDF9.Q_register;
   225.                   set_offline : in Boolean) is
   226.    begin
   227.       buffer(Q_operand.C and buffer_number_mask).POC(Q_operand, set_offline);
   228.       add_in_the_IO_lockout_CPU_time(Q_operand);
   229.    end POC;
   230.
   231.    procedure POD (Q_operand   : in KDF9.Q_register;
   232.                   set_offline : in Boolean) is
   233.    begin
   234.       buffer(Q_operand.C and buffer_number_mask).POD(Q_operand, set_offline);
   235.       add_in_the_IO_lockout_CPU_time(Q_operand);
   236.    end POD;
   237.
   238.    procedure POE (Q_operand   : in KDF9.Q_register;
   239.                   set_offline : in Boolean) is
   240.    begin
   241.       buffer(Q_operand.C and buffer_number_mask).POE(Q_operand, set_offline);
   242.    end POE;
   243.
   244.    procedure POF (Q_operand   : in KDF9.Q_register;
   245.                   set_offline : in Boolean) is
   246.    begin
   247.       buffer(Q_operand.C and buffer_number_mask).POF(Q_operand, set_offline);
   248.    end POF;
   249.
   250.    procedure POG (Q_operand   : in KDF9.Q_register;
   251.                   set_offline : in Boolean) is
   252.    begin
   253.       buffer(Q_operand.C and buffer_number_mask).POG(Q_operand, set_offline);
   254.    end POG;
   255.
   256.    procedure POH (Q_operand   : in KDF9.Q_register;
   257.                   set_offline : in Boolean) is
   258.    begin
   259.       buffer(Q_operand.C and buffer_number_mask).POH(Q_operand, set_offline);
   260.    end POH;
   261.
   262.    procedure POK (Q_operand   : in KDF9.Q_register;
   263.                   set_offline : in Boolean) is
   264.    begin
   265.       buffer(Q_operand.C and buffer_number_mask).POK(Q_operand, set_offline);
   266.    end POK;
   267.
   268.    procedure POL (Q_operand   : in KDF9.Q_register;
   269.                   set_offline : in Boolean) is
   270.    begin
   271.       buffer(Q_operand.C and buffer_number_mask).POL(Q_operand, set_offline);
   272.    end POL;
   273.
   274. end IOC.assignment;

Compiling: ../Source\ioc-assignment.ads
Source file time stamp: 2015-06-18 00:56:38
Compiled at: 2015-10-28 18:15:09

     1. -- ioc-assignment.ads
     2. --
     3. -- CPU I/O orders are assigned here to device-specific buffers within IOC.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package IOC.assignment is
    20.
    21.    pragma Unsuppress(All_Checks);
    22.
    23.    procedure BUSY (Q_operand   : in KDF9.Q_register;
    24.                    set_offline : in Boolean;
    25.                    result      : out KDF9.word);
    26.
    27.    procedure PAR (Q_operand   : in KDF9.Q_register;
    28.                   set_offline : in Boolean;
    29.                   result      : out KDF9.word);
    30.
    31.    procedure TLO (Q_operand   : in KDF9.Q_register;
    32.                   result      : out KDF9.word);
    33.
    34.    procedure CTQ (Q_operand   : in KDF9.Q_register;
    35.                   set_offline : in Boolean);
    36.
    37.    procedure CLO (Q_operand   : in KDF9.Q_register;
    38.                   set_offline : in Boolean);
    39.
    40.    procedure SLO (Q_operand   : in KDF9.Q_register;
    41.                   set_offline : in Boolean);
    42.
    43.    procedure INT (Q_operand   : in KDF9.Q_register;
    44.                   set_offline : in Boolean);
    45.
    46.    procedure PIA (Q_operand   : in KDF9.Q_register;
    47.                   set_offline : in Boolean);
    48.
    49.    procedure PIB (Q_operand   : in KDF9.Q_register;
    50.                   set_offline : in Boolean);
    51.
    52.    procedure PIC (Q_operand   : in KDF9.Q_register;
    53.                   set_offline : in Boolean);
    54.
    55.    procedure PID (Q_operand   : in KDF9.Q_register;
    56.                   set_offline : in Boolean);
    57.
    58.    procedure PIE (Q_operand   : in KDF9.Q_register;
    59.                   set_offline : in Boolean);
    60.
    61.    procedure PIF (Q_operand   : in KDF9.Q_register;
    62.                   set_offline : in Boolean);
    63.
    64.    procedure PIG (Q_operand   : in KDF9.Q_register;
    65.                   set_offline : in Boolean);
    66.
    67.    procedure PIH (Q_operand   : in KDF9.Q_register;
    68.                   set_offline : in Boolean);
    69.
    70.    procedure PMA (Q_operand   : in KDF9.Q_register;
    71.                   set_offline : in Boolean);
    72.
    73.    procedure PMB (Q_operand   : in KDF9.Q_register;
    74.                   set_offline : in Boolean);
    75.
    76.    procedure PMC (Q_operand   : in KDF9.Q_register;
    77.                   set_offline : in Boolean);
    78.
    79.    procedure PMD (Q_operand   : in KDF9.Q_register;
    80.                   set_offline : in Boolean);
    81.
    82.    procedure PME (Q_operand   : in KDF9.Q_register;
    83.                   set_offline : in Boolean);
    84.
    85.    procedure PMF (Q_operand   : in KDF9.Q_register;
    86.                   set_offline : in Boolean);
    87.
    88.    procedure PMG (Q_operand   : in KDF9.Q_register;
    89.                   set_offline : in Boolean);
    90.
    91.    procedure PMH (Q_operand   : in KDF9.Q_register;
    92.                   set_offline : in Boolean);
    93.
    94.    procedure PMK (Q_operand   : in KDF9.Q_register;
    95.                   set_offline : in Boolean);
    96.
    97.    procedure PML (Q_operand   : in KDF9.Q_register;
    98.                   set_offline : in Boolean);
    99.
   100.    procedure POA (Q_operand   : in KDF9.Q_register;
   101.                   set_offline : in Boolean);
   102.
   103.    procedure POB (Q_operand   : in KDF9.Q_register;
   104.                   set_offline : in Boolean);
   105.
   106.    procedure POC (Q_operand   : in KDF9.Q_register;
   107.                   set_offline : in Boolean);
   108.
   109.    procedure POD (Q_operand   : in KDF9.Q_register;
   110.                   set_offline : in Boolean);
   111.
   112.    procedure POE (Q_operand   : in KDF9.Q_register;
   113.                   set_offline : in Boolean);
   114.
   115.    procedure POF (Q_operand   : in KDF9.Q_register;
   116.                   set_offline : in Boolean);
   117.
   118.    procedure POG (Q_operand   : in KDF9.Q_register;
   119.                   set_offline : in Boolean);
   120.
   121.    procedure POH (Q_operand   : in KDF9.Q_register;
   122.                   set_offline : in Boolean);
   123.
   124.    procedure POK (Q_operand   : in KDF9.Q_register;
   125.                   set_offline : in Boolean);
   126.
   127.    procedure POL (Q_operand   : in KDF9.Q_register;
   128.                   set_offline : in Boolean);
   129.
   130. end IOC.assignment;
   131.

 274 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\fd_layout.adb
Source file time stamp: 2015-06-18 00:56:54
Compiled at: 2015-10-28 18:15:11

     1. -- disc.ads
     2. --
     3. -- Storage format of a fixed disc drive system.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. package body FD_layout is
    20.
    21.    -- Hypothesis:
    22.    -- Where a specification of the Fixed Disc subsystem cannot be inferred from extant
    23.    -- software, such as the Eldon 2 Director, or the EE KDF9 Programming Manual,
    24.    -- then it is reasonable to extrapolate from the document:
    25.    --    "GENERAL INFORMATION MANUAL dp/f-5022 DISCfILE (sic) STORAGE SYSTEM",
    26.    -- by Data Products Corporation, dated March 1965; which describes a similar model.
    27.    -- This document is referred to here as "GIM".
    28.    -- Confirmation of much of this material has been gained from the ICT document:
    29.    --    "Data Disc Store 1956:, dated September 1964"
    30.    -- which describes the same device offered as the first disc drive for the 1900 Series.
    31.    -- All three depict the drive as having a different division of tracks into sectors.
    32.
    33.    disc_addressing_error : exception;
    34.
    35.    -- Hypothesis:
    36.    -- The format of the disc address assumed here follows that given in GIM.
    37.    function locus_from (Q_operand : KDF9.Q_register)
    38.    return disc.locus is
    39.       parameter : constant KDF9.Q_part := Q_operand.C / 16; -- remove the buffer number
    40.       seek_area : constant KDF9.Q_part := parameter mod seek_areas_per_platter;
    41.       platter   : constant KDF9.Q_part
    42.                 := parameter / seek_areas_per_platter mod platters_per_drive;
    43.       drive     : constant KDF9.Q_part
    44.                 := parameter / seek_areas_per_platter / platters_per_drive;
    45.    begin
    46.       if drive > disc.drive_number'Last then
    47.          raise disc_addressing_error with "invalid unit number " & KDF9.Q_part'Image(drive);
    48.       end if;
    49.       -- Hypothesis:
    50.       -- Seeking to a new locus zeroizes the sector number and clears the end-of-area flag.
    51.       return (
    52.               drive_number      => drive,
    53.               platter_number    => platter,
    54.               seek_area_number  => seek_area,
    55.               sector_number     => 0,
    56.               is_at_end_of_area => 0
    57.              );
    58.    end locus_from;
    59.
    60.    -- These functions are used to avoid a cyclical dependency on the formatting package.
    61.
    62.    subtype decimal is KDF9.Q_part range 0 .. 9;
    63.
    64.    function digit (N : decimal)
    65.    return Character is
    66.    begin
    67.       return Character'Val(N + Character'Pos('0'));
    68.    end digit;
    69.
    70.    subtype centennial is KDF9.Q_part range 0 .. 99;
    71.
    72.    -- Return N as 2 decimal digits.
    73.    function dec_of (N : centennial)
    74.    return String is
    75.    begin
    76.       return (1 => digit(N/10), 2 => digit(N mod 10));
    77.    end dec_of;
    78.
    79.    function formatted_as_FD_command (Q_operand : in KDF9.Q_register)
    80.    return String is
    81.       locus : constant disc.locus := locus_from(Q_operand);
    82.    begin
    83.       return "D" & dec_of(locus.drive_number)(2)
    84.            & "P" & dec_of(locus.platter_number)
    85.            & "S" & dec_of(locus.seek_area_number);
    86.    end formatted_as_FD_command;
    87.
    88. end FD_layout;

Compiling: ../Source\fd_layout.ads
Source file time stamp: 2015-06-18 00:56:52
Compiled at: 2015-10-28 18:15:11

     1. -- fd_layout.ads
     2. --
     3. -- Storage format of a fixed disc drive system.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9;
    20.
    21. use  KDF9;
    22.
    23. package FD_layout is
    24.
    25.    pragma Unsuppress(All_Checks);
    26.
    27.    package disc renames FD_layout;
    28.
    29.    sector_size           : constant := 40;
    30.    bytes_per_sector      : constant := 8 * disc.sector_size;
    31.
    32.    type sector_data      is array (KDF9.address range 0 .. disc.bytes_per_sector-1)
    33.                          of KDF9.symbol;
    34.
    35.    sectors_per_seek_area : constant := 96;
    36.
    37.    subtype sector_number is KDF9.Q_part range 0 .. disc.sectors_per_seek_area-1;
    38.
    39.    type sector_array     is array (KDF9.Q_part range <>) of disc.sector_data;
    40.
    41.    subtype head_number   is KDF9.Q_part range 0 .. 7;
    42.
    43.    subtype inner_track   is disc.sector_array(disc.sector_number range 0 .. 7);
    44.    subtype outer_track   is disc.sector_array(disc.sector_number range 0  .. 15);
    45.
    46.    last_sector_for_head  : constant array (disc.head_number) of disc.sector_number
    47.                          := (0 .. 3 => disc.outer_track'Last,
    48.                              4 .. 7 => disc.inner_track'Last);
    49.
    50.    type outer_data       is array (disc.head_number range 0 .. 3) of disc.outer_track;
    51.    type inner_data       is array (disc.head_number range 4 .. 7) of disc.inner_track;
    52.
    53.    type track_set is
    54.       record
    55.          outer_zone : disc.outer_data;
    56.          inner_zone : disc.inner_data;
    57.       end record;
    58.
    59.    seek_areas_per_platter   : constant := 64;
    60.
    61.    subtype seek_area_number is KDF9.Q_part range 0 .. disc.seek_areas_per_platter-1;
    62.
    63.    platters_per_drive       : constant := 16;
    64.
    65.    subtype platter_number   is KDF9.Q_part range 0 .. disc.platters_per_drive-1;
    66.
    67.    -- The Eldon 2 KDF9 at Leeds University had a 2-drive disc system.
    68.    -- This allows for the maximum number of drives possible.
    69.    number_of_drives : constant := 4;
    70.
    71.    subtype drive_number is KDF9.Q_part range 0 .. disc.number_of_drives-1;
    72.
    73.    type locus is
    74.       record
    75.          drive_number      : disc.drive_number     := 0;
    76.          platter_number    : disc.platter_number   := 0;
    77.          seek_area_number  : disc.seek_area_number := 0;
    78.          sector_number     : disc.sector_number    := 0;
    79.          is_at_end_of_area : KDF9.word := 0;
    80.       end record;
    81.
    82.    function locus_from (Q_operand : KDF9.Q_register)
    83.    return disc.locus;
    84.
    85.    function formatted_as_FD_command (Q_operand : KDF9.Q_register)
    86.    return String;
    87.
    88. end FD_layout;

 88 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\generic_sets.adb
Source file time stamp: 2015-06-18 00:56:46
Compiled at: 2015-10-28 18:15:12

     1. -- generic_sets.adb
     2. --
     3. -- Arbitrary-sized sets of a discrete member type.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. -- generic
    20. --    type member is (<>);
    21. package body generic_sets is
    22.
    23.    pragma Unsuppress(All_Checks);
    24.
    25.    function "abs" (set : generic_sets.set)
    26.    return Natural is
    27.       result : Natural := 0;
    28.    begin
    29.       for member in generic_sets.member loop
    30.          if set/member then
    31.             result := result + 1;
    32.          end if;
    33.       end loop;
    34.       return result;
    35.    end "abs";
    36.
    37.    function is_empty (set : generic_sets.set)
    38.    return Boolean is
    39.    begin
    40.       return set = empty_set;
    41.    end is_empty;
    42.
    43.    function singleton (member : generic_sets.member)
    44.    return generic_sets.set is
    45.    begin
    46.       return result : generic_sets.set := empty_set do
    47.          result(member) := True;
    48.       end return;
    49.    end singleton;
    50.
    51.    function interval (low, high : generic_sets.member)
    52.    return generic_sets.set is
    53.    begin
    54.       return result : generic_sets.set := empty_set do
    55.          result(low .. high) := (others => True);
    56.       end return;
    57.    end interval;
    58.
    59.    function "/" (member : generic_sets.member; set : generic_sets.set)
    60.    return Boolean is
    61.    begin
    62.       return set(member);
    63.    end "/";
    64.
    65.    function "/" (set : generic_sets.set; member : generic_sets.member)
    66.    return Boolean is
    67.    begin
    68.       return set(member);
    69.    end "/";
    70.
    71.    function "not" (member : generic_sets.member)
    72.    return generic_sets.set is
    73.    begin
    74.       return result : generic_sets.set := universe do
    75.          result(member) := False;
    76.       end return;
    77.    end "not";
    78.
    79.    function "and" (member : generic_sets.member; set : generic_sets.set)
    80.    return generic_sets.set is
    81.    begin
    82.       return result : generic_sets.set := empty_set do
    83.          result(member) := set(member);
    84.       end return;
    85.    end "and";
    86.
    87.    function "and" (set : generic_sets.set; member : generic_sets.member)
    88.    return generic_sets.set is
    89.    begin
    90.       return result : generic_sets.set := empty_set do
    91.          result(member) := set(member);
    92.       end return;
    93.    end "and";
    94.
    95.    function "or" (member : generic_sets.member; set : generic_sets.set)
    96.    return generic_sets.set is
    97.    begin
    98.       return result : generic_sets.set := set do
    99.          result(member) := True;
   100.       end return;
   101.    end "or";
   102.
   103.    function "or" (set : generic_sets.set; member : generic_sets.member)
   104.    return generic_sets.set is
   105.    begin
   106.       return result : generic_sets.set := set do
   107.          result(member) := True;
   108.       end return;
   109.    end "or";
   110.
   111.    function "xor" (member : generic_sets.member; set : generic_sets.set)
   112.    return generic_sets.set is
   113.    begin
   114.       return result : generic_sets.set := set do
   115.          result(member) := not set(member);
   116.       end return;
   117.    end "xor";
   118.
   119.    function "xor" (set : generic_sets.set; member : generic_sets.member)
   120.    return generic_sets.set is
   121.    begin
   122.       return result : generic_sets.set := set do
   123.          result(member) := not set(member);
   124.       end return;
   125.    end "xor";
   126.
   127.    function "-" (set : generic_sets.set; member : generic_sets.member)
   128.    return generic_sets.set is
   129.    begin
   130.       return result : generic_sets.set := set do
   131.          result(member) := False;
   132.       end return;
   133.    end "-";
   134.
   135.    function "-" (set1, set2 : generic_sets.set)
   136.    return generic_sets.set is
   137.    begin
   138.       return set1 and not set2;
   139.    end "-";
   140.
   141.    overriding
   142.    function "<=" (set1, set2 : generic_sets.set)
   143.    return Boolean is
   144.    begin
   145.       return set1 = (set1 and set2);
   146.    end "<=";
   147.
   148.    overriding
   149.    function "<"  (set1, set2 : generic_sets.set)
   150.    return Boolean is
   151.    begin
   152.       return (set1 <= set2) and (set1 /= set2);
   153.    end "<";
   154.
   155. end generic_sets;

Compiling: ../Source\generic_sets.ads
Source file time stamp: 2015-06-18 00:56:42
Compiled at: 2015-10-28 18:15:12

     1. -- generic_sets.ads
     2. --
     3. -- Arbitrary-sized sets of a discrete member type.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. generic
    20.    type member is (<>);
    21. package generic_sets is
    22.
    23.    pragma Unsuppress(All_Checks);
    24.
    25.    type set is array (generic_sets.member) of Boolean;
    26.    for  set'Component_Size use 1;
    27.    pragma Convention(C, Entity => set);
    28.
    29.    universe  : constant generic_sets.set;
    30.
    31.    empty_set : constant generic_sets.set;
    32.
    33.    function is_empty (set : generic_sets.set)
    34.    return Boolean;
    35.
    36.    -- The cardinality of the set.
    37.    function "abs" (set : generic_sets.set)
    38.    return Natural;
    39.
    40.    -- Test for membership of the set.
    41.    function "/" (set : generic_sets.set; member : generic_sets.member)
    42.    return Boolean;
    43.
    44.    function "/" (member : generic_sets.member; set : generic_sets.set)
    45.    return Boolean;
    46.
    47.    -- Constructors.
    48.
    49.    function singleton (member : generic_sets.member)
    50.    return generic_sets.set;
    51.
    52.    function interval  (low, high : generic_sets.member)
    53.    return generic_sets.set;
    54.
    55.    function "not" (member : generic_sets.member)
    56.    return generic_sets.set;
    57.
    58. -- "not" (set : generic_sets.set) is predefined
    59.
    60.    function "and" (member : generic_sets.member; set : generic_sets.set)
    61.    return generic_sets.set;
    62.
    63.    function "and" (set : generic_sets.set; member : generic_sets.member)
    64.    return generic_sets.set;
    65.
    66. -- "and" (set1, set2 : generic_sets.set) is predefined
    67.
    68.    function "or"  (member : generic_sets.member; set : generic_sets.set)
    69.    return generic_sets.set;
    70.
    71.    function "or"  (set : generic_sets.set; member : generic_sets.member)
    72.    return generic_sets.set;
    73.
    74. -- "or"  (set1, set2 : generic_sets.set) is predefined
    75.
    76.    function "xor" (member : generic_sets.member; set : generic_sets.set)
    77.    return generic_sets.set;
    78.
    79.    function "xor" (set : generic_sets.set; member : generic_sets.member)
    80.    return generic_sets.set;
    81.
    82. -- "xor" (set1, set2 : generic_sets.set) is predefined
    83.
    84.    function "-" (set : generic_sets.set; member : generic_sets.member)
    85.    return generic_sets.set;
    86.
    87.    function "-" (set1, set2 : generic_sets.set)
    88.    return generic_sets.set;
    89.
    90.    -- subset
    91.    overriding
    92.    function "<=" (set1, set2 : generic_sets.set)
    93.    return Boolean;
    94.
    95.    -- proper subset
    96.    overriding
    97.    function "<"  (set1, set2 : generic_sets.set)
    98.    return Boolean;
    99.
   100. private
   101.
   102.    universe  : constant generic_sets.set := (others => True);
   103.
   104.    empty_set : constant generic_sets.set := (others => False);
   105.
   106. end generic_sets;

 155 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\file_interfacing.adb
Source file time stamp: 2015-06-18 00:56:52
Compiled at: 2015-10-28 18:15:12

     1. -- file_IO_interface.adb
     2. --
     3. -- Provide an Ada.Text_IO interface to the file system of the real OS.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Exceptions;
    20. --
    21. with HCI;
    22.
    23. use  HCI;
    24.
    25. package body file_interfacing is
    26.
    27.    pragma Unsuppress(All_Checks);
    28.
    29.    procedure initialize (some_file : in out File_Type;
    30.                          mode      : in File_Mode;
    31.                          file_name : in String) is
    32.    begin
    33.       Open(some_file, mode, file_name);
    34.    exception
    35.       when others =>
    36.          if mode = Out_File then
    37.             Create(some_file, Out_File, file_name);
    38.          else
    39.             raise;
    40.          end if;
    41.    end initialize;
    42.
    43.    procedure finalize (some_file : in out File_Type;
    44.                        file_name : in String) is
    45.    begin
    46.       Close(some_file);
    47.    exception
    48.       when error : others =>
    49.          log_line("Failure in ee9: "
    50.                 & Ada.Exceptions.Exception_Information(error)
    51.                 & " was raised for '" & file_name & "'"
    52.                 & " in 'file_interfacing.finalize'!");
    53.          raise;
    54.    end finalize;
    55.
    56. end file_interfacing;

Compiling: ../Source\file_interfacing.ads
Source file time stamp: 2015-06-18 00:56:50
Compiled at: 2015-10-28 18:15:12

     1. -- file_interfacing.ads
     2. --
     3. -- Provide an Ada.Text_IO interface to the file system of the real OS.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with Ada.Text_IO;
    20.
    21. use  Ada.Text_IO;
    22.
    23. package file_interfacing is
    24.
    25.    pragma Unsuppress(All_Checks);
    26.
    27.    procedure initialize (some_file : in out File_Type;
    28.                          mode      : in File_Mode;
    29.                          file_name : in String);
    30.
    31.    procedure finalize (some_file : in out File_Type;
    32.                        file_name : in String);
    33.
    34. end file_interfacing;

 56 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\os_specifics.adb
Source file time stamp: 2015-10-28 18:13:20
Compiled at: 2015-10-28 18:15:13

     1. -- OS_specifics.adb
     2. --
     3. -- Special operations for the console streams.
     4. -- This is the Windows (i.e., crippled) version.
     5. --
     6. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     7. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     8. --
     9. -- The ee9 program is free software; you can redistribute it and/or
    10. -- modify it under terms of the GNU General Public License as published
    11. -- by the Free Software Foundation; either version 3, or (at your option)
    12. -- any later version. This program is distributed in the hope that it
    13. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    14. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    15. -- See the GNU General Public License for more details. You should have
    16. -- received a copy of the GNU General Public License distributed with
    17. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    18. --
    19.
    20. with Interfaces.C;
    21. --
    22. with Latin_1;
    23. with POSIX;
    24.
    25. use  Latin_1;
    26. use  POSIX;
    27.
    28. package body OS_specifics is
    29.
    30.    package C renames Interfaces.C;
    31.    use C;
    32.
    33.    function get_O_BINARY return C.int;
    34.    pragma Import(C, get_O_BINARY, External_Name => "get_O_BINARY");
    35.
    36.    function setmode (fd : C.int; mode : C.int) return C.int;
    37.    pragma Import(C, setmode, External_Name => "setmode");
    38.
    39.    procedure make_transparent (fd : in Integer) is
    40.       response : C.int;
    41.    begin
    42.       -- Convince Windows not to corrupt binary data.
    43.       response := setmode(C.int(fd), get_O_BINARY);
    44.       if response < 0 then  -- Either setmode or get_O_BINARY failed.
    45.          raise Program_Error
    46.             with "make_transparent failed, response = " & C.int'Image(response);
    47.       end if;
    48.    end make_transparent;
    49.
    50.    function the_terminal_is_ANSI_compatible
    51.    return Boolean
    52.    renames False;
    53.
    54.    procedure set_text_colour_to_red (the_flexowriter_output : in out IO.stream) is
    55.    begin
    56.       flush(the_flexowriter_output);
    57.    end set_text_colour_to_red;
    58.
    59.    procedure set_text_colour_to_black (the_flexowriter_output : in out IO.stream) is
    60.    begin
    61.       flush(the_flexowriter_output);
    62.    end set_text_colour_to_black;
    63.
    64.    function EOL
    65.    return String is
    66.    begin
    67.       return (1 => CR, 2 => LF);
    68.    end EOL;
    69.
    70.    procedure open_ui is
    71.       ui_in_name  : constant String := "CONIN$";
    72.       ui_out_name : constant String := "CONOUT$";
    73.    begin
    74.       ui_in_fd := open(ui_in_name, read_mode);
    75.       verify(ui_in_fd, ui_in_name);
    76.       ui_out_fd := open(ui_out_name, write_mode);
    77.       verify(ui_out_fd, ui_out_name);
    78.       ui_is_open := True;
    79.    end open_ui;
    80.
    81. end OS_specifics;

Compiling: ../Source\os_specifics.ads
Source file time stamp: 2015-06-18 00:55:52
Compiled at: 2015-10-28 18:15:13

     1. -- OS_specifics.ads
     2. --
     3. -- Special operations for the console terminal streams.
     4. -- This specification is the same for the Windows, Linux, OS X and UNIX versions;
     5. --    although not all features are used in all system types.
     6. --
     7. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     8. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     9. --
    10. -- The ee9 program is free software; you can redistribute it and/or
    11. -- modify it under terms of the GNU General Public License as published
    12. -- by the Free Software Foundation; either version 3, or (at your option)
    13. -- any later version. This program is distributed in the hope that it
    14. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    15. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    16. -- See the GNU General Public License for more details. You should have
    17. -- received a copy of the GNU General Public License distributed with
    18. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    19. --
    20.
    21. with IO;
    22.
    23. use  IO;
    24.
    25. package OS_specifics is
    26.
    27.    pragma Unsuppress(All_Checks);
    28.
    29.    -- open_ui opens /dev/tty on UNIX systems and CON{IN|OUT}$ on Windows.
    30.    procedure open_ui;
    31.
    32.    -- make_transparent sets the "binary" mode of I/O on Windows/Cygwin;
    33.    --    it does nothing on UNIX-family systems, where no such precaution is necessary.
    34.    procedure make_transparent (fd : in Integer);
    35.
    36.    function the_terminal_is_ANSI_compatible
    37.    return Boolean;
    38.
    39.    -- set_text_colour_to_* is effective iff the_terminal_is_ANSI_compatible yields True.
    40.    procedure set_text_colour_to_red   (the_flexowriter_output : in out IO.stream);
    41.
    42.    procedure set_text_colour_to_black (the_flexowriter_output : in out IO.stream);
    43.
    44.    -- EOL returns the appropriate line terminator for the selected host OS:
    45.    -- LF for OS X/UNIX/Linux,
    46.    -- CRLF for Windows.
    47.    function EOL
    48.    return String;
    49.
    50. end OS_specifics;

 81 lines: No errors

GNAT GPL 2015 (20150428-49)
Copyright 1992-2015, Free Software Foundation, Inc.


Compiling: C:\cygwin\home\bgallagher\emulation\Source\plotter.adb
Source file time stamp: 2015-06-18 00:55:48
Compiled at: 2015-10-28 18:15:14

     1. -- plotter.adb
     2. --
     3. -- Emulation of the plotting commands of the Calcomp 564 graph plotter.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with postscript; pragma Elaborate_All(postscript);
    20.
    21. use  postscript;
    22.
    23. package body plotter is
    24.
    25.    pragma Unsuppress(All_Checks);
    26.
    27.    -- The plotter made equal movements in the x and y directions, in quanta of 0.005 inches.
    28.    -- Each command moves the plotting position by at most 1 quantum,
    29.    --   in either the positive or negative direction of each axis.
    30.
    31.    subtype step_change is Integer range -1 .. +1;
    32.
    33.    type step is
    34.       record
    35.          dx, dy : step_change;
    36.       end record;
    37.
    38.    function "+" (p : postscript.point; s : plotter.step)
    39.    return postscript.point is
    40.    begin
    41.       return (p.x + s.dx, p.y + s.dy);
    42.    end "+";
    43.
    44.    function "-" (p, q : postscript.point)
    45.    return plotter.step is
    46.    begin
    47.       return (p.x - q.x, p.y - q.y);  -- Consecutive points are at most one unit apart.
    48.    end "-";
    49.
    50.    -- The plotter drew on a roll of paper 29.5 inches wide and 120 feet long.
    51.    -- 29.5" is   5900 steps at 200 steps per inch = 59 * 100
    52.    -- 120'  is 288000 steps  = 200 per inch * 12 inches per foot * 120 feet.
    53.    -- This sets the boundaries of the plot.
    54.    -- It was physically impossible to move to a point beyond these limits.
    55.
    56.    plot_limit : constant postscript.point := (120*12*200, 59*100);
    57.
    58.    -- A vector is represented by a series of consecutive colinear plotter movements.
    59.    -- For better efficiency, the steps of a vector are accumulated until there is
    60.    --    a change of direction, a pen lift, or the need to close the plotter file.
    61.    -- On these events, any vector thus defined is drawn via a single PostScript command.
    62.
    63.    -- last_step retains the direction of the previous plotter step.
    64.    last_step : plotter.step := (0, 0);
    65.
    66.    plot_position,
    67.    start_position : postscript.point := (+0, +0);
    68.
    69.    the_pen_is_down : Boolean := False;
    70.
    71.    procedure close_any_open_vector is
    72.    begin
    73.       if the_pen_is_down                and then
    74.             start_position /= plot_position then
    75.          draw_a_PostScript_vector(start_position, plot_position);
    76.          start_position := plot_position;
    77.       end if;
    78.    end close_any_open_vector;
    79.
    80.    procedure draw_to (p : in postscript.point);
    81.    pragma Inline(draw_to);
    82.
    83.    procedure draw_to (p : in postscript.point) is
    84.    begin
    85.       if (plot_position - p) = last_step then
    86.          -- p is colinear with the previous step, so merely extend the vector to p.
    87.          plot_position := p;
    88.       else
    89.          -- Draw the whole vector and start a new one.
    90.          draw_a_PostScript_vector(start_position, plot_position);
    91.          last_step := plot_position - p;
    92.          start_position := plot_position;
    93.          plot_position := p;
    94.       end if;
    95.    end draw_to;
    96.
    97.    procedure jump_to (p : in postscript.point);
    98.    pragma Inline(jump_to);
    99.
   100.    procedure jump_to (p : in postscript.point) is
   101.    begin
   102.       -- Posit a new vector starting at p.
   103.       last_step := (0, 0);
   104.       plot_position := p;
   105.       start_position := p;
   106.    end;
   107.
   108.    procedure ensure_the_validity_of (this  : in postscript.point;
   109.                                      after : in plotter.step) is
   110.    begin
   111.       if this.x + after.dx < 0                     or else
   112.             this.y + after.dy < 0                  or else
   113.                this.x + after.dx > plot_limit.x    or else
   114.                   this.y + after.dy > plot_limit.y    then
   115.          raise plotting_error
   116.             with "movement to an impossible position from ("
   117.                 & this.x'Img
   118.                 & this.y'Img
   119.                 & ") by ("
   120.                 & after.dx'Img
   121.                 & after.dy'Img
   122.                 & ")"
   123.                 ;
   124.       end if;
   125.    end ensure_the_validity_of;
   126.
   127.    procedure draw_by (this_step : in plotter.step);
   128.    pragma Inline(draw_by);
   129.
   130.    procedure draw_by (this_step : in plotter.step) is
   131.    begin
   132.       ensure_the_validity_of(this => plot_position, after => this_step);
   133.       draw_to(plot_position + this_step);
   134.    exception
   135.       when plotting_error =>
   136.          null;
   137.    end draw_by;
   138.
   139.    procedure jump_by (this_step : in plotter.step);
   140.    pragma Inline(jump_by);
   141.
   142.    procedure jump_by (this_step : in plotter.step) is
   143.    begin
   144.       ensure_the_validity_of(this => plot_position, after => this_step);
   145.       jump_to(plot_position + this_step);
   146.    exception
   147.       when plotting_error =>
   148.          null;
   149.    end jump_by;
   150.
   151.    procedure move_by (this_step : in plotter.step);
   152.    pragma Inline(move_by);
   153.
   154.    procedure move_by (this_step : in plotter.step) is
   155.    begin
   156.       -- Convert from natural orientation of X axis to PostScript direction.
   157.       if the_pen_is_down then
   158.          draw_by((-this_step.dx, +this_step.dy));
   159.       else
   160.          jump_by((-this_step.dx, +this_step.dy));
   161.       end if;
   162.    end move_by;
   163.
   164.    procedure perform (symbol : in plotter.command) is
   165.    begin
   166.       case symbol is
   167.          when dummy =>
   168.             null;
   169.          when pen_up =>
   170.             close_any_open_vector;
   171.             the_pen_is_down := False;
   172.          when pen_down =>
   173.             the_pen_is_down := True;
   174.          when go_pY =>
   175.             move_by((+0, +1));
   176.          when go_nY =>
   177.             move_by((+0, -1));
   178.          when go_pX =>
   179.             move_by((+1, +0));
   180.          when go_nX =>
   181.             move_by((-1, +0));
   182.          when go_pXpY =>
   183.             move_by((+1, +1));
   184.          when go_nXnY =>
   185.             move_by((-1, -1));
   186.          when others =>
   187.             close_the_plot_file;
   188.             raise plotting_error with "invalid plotter command";
   189.       end case;
   190.    end perform;
   191.
   192.    a_plot_is_open : Boolean := False;
   193.
   194.    procedure open_the_plot_file is
   195.    begin
   196.       if a_plot_is_open then
   197.          close_the_plot_file;
   198.          raise plotting_error with "the plotter was already open";
   199.       end if;
   200.       plot_position := (0,0);
   201.       a_plot_is_open := True;
   202.    end open_the_plot_file;
   203.
   204.    procedure close_the_plot_file is
   205.    begin
   206.       if not a_plot_is_open then
   207.          raise plotting_error with "the plotter was already closed";
   208.       end if;
   209.       close_any_open_vector;
   210.       a_plot_is_open := False;
   211.    end close_the_plot_file;
   212.
   213. end plotter;

Compiling: ../Source\plotter.ads
Source file time stamp: 2015-06-18 00:55:48
Compiled at: 2015-10-28 18:15:14

     1. -- plotter.ads
     2. --
     3. -- Emulation of the plotting commands of the Calcomp 564 graph plotter.
     4. --
     5. -- This file is part of ee9 (V2.0r), the GNU Ada emulator of the English Electric KDF9.
     6. -- Copyright (C) 2015, W. Findlay; all rights reserved.
     7. --
     8. -- The ee9 program is free software; you can redistribute it and/or
     9. -- modify it under terms of the GNU General Public License as published
    10. -- by the Free Software Foundation; either version 3, or (at your option)
    11. -- any later version. This program is distributed in the hope that it
    12. -- will be useful, but WITHOUT ANY WARRANTY; without even the implied
    13. -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    14. -- See the GNU General Public License for more details. You should have
    15. -- received a copy of the GNU General Public License distributed with
    16. -- this program; see file COPYING. If not, see <http://www.gnu.org/licenses/>.
    17. --
    18.
    19. with KDF9;
    20.
    21. use KDF9;
    22.
    23. package plotter is
    24.
    25.    procedure open_the_plot_file;
    26.
    27.    procedure close_the_plot_file;
    28.
    29.    type command is new KDF9.symbol;
    30.
    31.    -- These are the plotting commands defined in the Manual, Appendix 6, §5.3, pp. 303-304.
    32.
    33.    pen_up   : constant plotter.command := 2#100_000#;
    34.    pen_down : constant plotter.command := 2#010_000#;
    35.    go_pXpY  : constant plotter.command := 2#001_010#;
    36.    go_nXnY  : constant plotter.command := 2#001_001#;
    37.    go_pY    : constant plotter.command := 2#001_000#;
    38.    go_nY    : constant plotter.command := 2#000_100#;
    39.    go_pX    : constant plotter.command := 2#000_010#;
    40.    go_nX    : constant plotter.command := 2#000_001#;
    41.    dummy    : constant plotter.command := 2#000_000#;
    42.
    43.    is_valid : constant array (plotter.command) of Boolean
    44.             := (dummy    |
    45.                 pen_up   |
    46.                 pen_down |
    47.                 go_pY    |
    48.                 go_nY    |
    49.                 go_pX    |
    50.                 go_nX    |
    51.                 go_pXpY  |
    52.                 go_nXnY  => True,
    53.                 others   => False
    54.                );
    55.
    56.    procedure perform (symbol : in plotter.command);
    57.
    58.    -- This exception is raised by untimely calls on open_the_plot_file and close_the_plot_file;
    59.    --    by an attempt to move the plotting position to a physically impossible location;
    60.    --       and by a plotter.command value not listed in the Manual.
    61.    -- Before raising the exception, close_the_plot_file is invoked if necessary.
    62.
    63.    plotting_error : exception;
    64.
    65. end plotter;

 213 lines: No errors
