The TextEditor class is a simple text editor.

import java.awt.*;
import java.awt.event.*;
import javax.swing.*;
import java.io.*;

/**

*/

public class TextEditor extends JFrame
{
// The following are fields for the menu system.
// First, the menu bar
private JMenuBar menuBar;

// The menus
private JMenu fileMenu;
private JMenu fontMenu;

// The menu items
private JMenuItem newItem;
private JMenuItem openItem;
private JMenuItem saveItem;
private JMenuItem saveAsItem;
private JMenuItem exitItem;

// The radio button menu items
private JRadioButtonMenuItem monoItem;
private JRadioButtonMenuItem serifItem;
private JRadioButtonMenuItem sansSerifItem;

// The checkbox menu items
private JCheckBoxMenuItem italicItem;
private JCheckBoxMenuItem boldItem;

private String filename;     // To hold the file name
private JTextArea editorText;// To display the text
private final int NUM_LINES = 20;  // Lines to display
private final int NUM_CHARS = 40;  // Chars per line

/**
   Constructor
*/

public TextEditor()
{
   // Set the title.
   setTitle("Text Editor");

   // Specify what happens when the close
   // button is clicked.
   setDefaultCloseOperation(JFrame.EXIT_ON_CLOSE);

   // Create the text area.
   editorText = new JTextArea(NUM_LINES, NUM_CHARS);

   // Turn line wrapping on.
   editorText.setLineWrap(true);
   editorText.setWrapStyleWord(true);

   // Create a scroll pane and add the text area to it.
   JScrollPane scrollPane = new JScrollPane(editorText);

   // Add the scroll pane to the content pane.
   add(scrollPane);

   // Build the menu bar.
   buildMenuBar();

   // Pack and display the window.
   pack();
   setVisible(true);
}

/**
   The buildMenuBar method creates a menu bar and
   calls the createFileMenu method to create the
   file menu.
*/

private void buildMenuBar()
{
   // Build the file and font menus.
   buildFileMenu();
   buildFontMenu();

   // Create the menu bar.
   menuBar = new JMenuBar();

   // Add the file and font menus to the menu bar.
   menuBar.add(fileMenu);
   menuBar.add(fontMenu);

   // Set the menu bar for this frame.
   setJMenuBar(menuBar);
}

/**
   The buildFileMenu method creates the file menu
   and populates it with its menu items.
*/

private void buildFileMenu()
{
   // Create the New menu item.
   newItem = new JMenuItem("New");
   newItem.setMnemonic(KeyEvent.VK_N);
   newItem.addActionListener(new NewListener());

   // Create the Open menu item.
   openItem = new JMenuItem("Open");
   openItem.setMnemonic(KeyEvent.VK_O);
   openItem.addActionListener(new OpenListener());

   // Create the Save menu item.
   saveItem = new JMenuItem("Save");
   saveItem.setMnemonic(KeyEvent.VK_S);
   saveItem.addActionListener(new SaveListener());

   // Create the Save As menu item.
   saveAsItem = new JMenuItem("Save As");
   saveAsItem.setMnemonic(KeyEvent.VK_A);
   saveAsItem.addActionListener(new SaveListener());

   // Create the Exit menu item.
   exitItem = new JMenuItem("Exit");
   exitItem.setMnemonic(KeyEvent.VK_X);
   exitItem.addActionListener(new ExitListener());

   // Create a menu for the items we just created.
   fileMenu = new JMenu("File");
   fileMenu.setMnemonic(KeyEvent.VK_F);

   // Add the items and some separator bars to the menu.
   fileMenu.add(newItem);
   fileMenu.add(openItem);
   fileMenu.addSeparator();// Separator bar
   fileMenu.add(saveItem);
   fileMenu.add(saveAsItem);
   fileMenu.addSeparator();// Separator bar
   fileMenu.add(exitItem);
}

/**
   The buildFontMenu method creates the font menu
      and populates it with its menu items.
*/

private void buildFontMenu()
{
   // Create the Monospaced menu item.
   monoItem = new JRadioButtonMenuItem("Monospaced");
   monoItem.addActionListener(new FontListener());

   // Create the Serif menu item.
   serifItem = new JRadioButtonMenuItem("Serif");
   serifItem.addActionListener(new FontListener());

   // Create the SansSerif menu item.
   sansSerifItem =
           new JRadioButtonMenuItem("SansSerif", true);
   sansSerifItem.addActionListener(new FontListener());

   // Group the radio button menu items.
   ButtonGroup group = new ButtonGroup();
   group.add(monoItem);
   group.add(serifItem);
   group.add(sansSerifItem);

   // Create the Italic menu item.
   italicItem = new JCheckBoxMenuItem("Italic");
   italicItem.addActionListener(new FontListener());

   // Create the Bold menu item.
   boldItem = new JCheckBoxMenuItem("Bold");
   boldItem.addActionListener(new FontListener());

   // Create a menu for the items we just created.
   fontMenu = new JMenu("Font");
   fontMenu.setMnemonic(KeyEvent.VK_T);

   // Add the items and some separator bars to the menu.
   fontMenu.add(monoItem);
   fontMenu.add(serifItem);
   fontMenu.add(sansSerifItem);
   fontMenu.addSeparator();// Separator bar
   fontMenu.add(italicItem);
   fontMenu.add(boldItem);
}

/**
   Private inner class that handles the event that
   is generated when the user selects New from
   the file menu.
*/

private class NewListener implements ActionListener
{
   public void actionPerformed(ActionEvent e)
   {
      editorText.setText("");
      filename = null;
   }
}

/**
   Private inner class that handles the event that
   is generated when the user selects Open from
   the file menu.
*/

private class OpenListener implements ActionListener
{
   public void actionPerformed(ActionEvent e)
   {
      int chooserStatus;

      JFileChooser chooser = new JFileChooser();
      chooserStatus = chooser.showOpenDialog(null);
      if (chooserStatus == JFileChooser.APPROVE_OPTION)
      {
         // Get a reference to the selected file.
         File selectedFile = chooser.getSelectedFile();

         // Get the path of the selected file.
         filename = selectedFile.getPath();

         // Open the file.
         if (!openFile(filename))
         {
            JOptionPane.showMessageDialog(null,
                             "Error reading " +
                             filename, "Error",
                             JOptionPane.ERROR_MESSAGE);
         }
      }
   }

   /**
      The openFile method opens the file specified by
      filename and reads its contents into the text
      area. The method returns true if the file was
      opened and read successfully, or false if an
      error occurred.
      @param filename The name of the file to open.
   */

   private boolean openFile(String filename)
   {
      boolean success;
      String inputLine, editorString = "";
      FileReader freader;
      BufferedReader inputFile;

      try
      {
         // Open the file.
         freader = new FileReader(filename);
         inputFile = new BufferedReader(freader);

         // Read the file contents into the editor.
         inputLine = inputFile.readLine();
         while (inputLine != null)
         {
            editorString = editorString +
                           inputLine + "\n";
            inputLine = inputFile.readLine();
         }
         editorText.setText(editorString);

         // Close the file.
         inputFile.close();

         // Indicate that everything went OK.
         success = true;
      }
      catch (IOException e)
      {
         // Something went wrong.
         success = false;
      }

      // Return our status.
      return success;
   }
}

/**
   Private inner class that handles the event that
   is generated when the user selects Save or Save
   As from the file menu.
*/

private class SaveListener implements ActionListener
{
   public void actionPerformed(ActionEvent e)
   {
      int chooserStatus;

      // If the user selected Save As, or the contents
      // of the editor have not been saved, use a file
      // chooser to get the file name. Otherwise, save
      // the file under the current file name.

      if (e.getActionCommand() == "Save As" ||
          filename == null)
      {
         JFileChooser chooser = new JFileChooser();
         chooserStatus = chooser.showSaveDialog(null);
         if (chooserStatus == JFileChooser.APPROVE_OPTION)
         {
            // Get a reference to the selected file.
            File selectedFile =
                          chooser.getSelectedFile();

            // Get the path of the selected file.
            filename = selectedFile.getPath();
         }
      }

      // Save the file.
      if (!saveFile(filename))
      {
         JOptionPane.showMessageDialog(null,
                            "Error saving " +
                            filename,
                            "Error",
                            JOptionPane.ERROR_MESSAGE);
      }
   }

   /**
      The saveFile method saves the contents of the
      text area to a file. The method returns true if
      the file was saved successfully, or false if an
      error occurred.
      @param filename The name of the file.
      @return true if successful, false otherwise.
   */

   private boolean saveFile(String filename)
   {
      boolean success;
      String editorString;
      FileWriter fwriter;
      PrintWriter outputFile;

      try
      {
         // Open the file.
         fwriter = new FileWriter(filename);
         outputFile = new PrintWriter(fwriter);

         // Write the contents of the text area
         // to the file.
         editorString = editorText.getText();
         outputFile.print(editorString);

         // Close the file.
         outputFile.close();

         // Indicate that everything went OK.
         success = true;
      }
      catch (IOException e)
      {
         // Something went wrong.
          success = false;
      }

      // Return our status.
      return success;
   }
}

/**
   Private inner class that handles the event that
   is generated when the user selects Exit from
   the file menu.
*/

private class ExitListener implements ActionListener
{
   public void actionPerformed(ActionEvent e)
   {
      System.exit(0);
   }
}

/**
   Private inner class that handles the event that
   is generated when the user selects an item from
   the font menu.
*/

private class FontListener implements ActionListener
{
   public void actionPerformed(ActionEvent e)
   {
      // Get the current font.
      Font textFont = editorText.getFont();

      // Retrieve the font name and size.
      String fontName = textFont.getName();
      int fontSize = textFont.getSize();

      // Start with plain style.
      int fontStyle = Font.PLAIN;

      // Determine which font is selected.
      if (monoItem.isSelected())
         fontName = "Monospaced";
      else if (serifItem.isSelected())
         fontName = "Serif";
      else if (sansSerifItem.isSelected())
         fontName = "SansSerif";

      // Determine whether italic is selected.
      if (italicItem.isSelected())
         fontStyle += Font.ITALIC;

      // Determine whether bold is selected.
      if (boldItem.isSelected())
         fontStyle += Font.BOLD;

      // Set the font as selected.
      editorText.setFont(new Font(fontName,
                             fontStyle, fontSize));
   }
}

/**
   main method
*/

public static void main(String[] args)
{
   TextEditor te = new TextEditor();
}
}

Header File and Library Function Reference

This appendix provides a reference for the C++ library functions discussed in the book.
The following table gives an alphabetical list of functions. Tables of functions that are
organized by their header files follow it.
Table I-1 Alphabetical Listing of Selected Library Functions
Function Details
abs(m)
Header File:
cmath
Description:
Accepts an integer argument. Returns the absolute value of the argument
as an integer.
Example:
a = abs(m);
atof(str)
Header File:
cstdlib
Description:
Accepts a C-string as an argument. The function converts the string to a
double
and returns that value.
Example:
num = atof("3.14159");
atoi(str)
Header File:
cstdlib
Description:
Accepts a C-string as an argument. The function converts the string to an
int
and returns that value.
Example:
num = atoi("4569");
atol(str)
Header File:
cstdlib
Description:
Accepts a C-string as an argument. The function converts the string to a
long
and returns that value.
Example:
num = atol("5000000");
2
Appendix I: Header File and Library Function Reference
cos(m)
Header File:
cmath
Description:
Accepts a
double
argument. Returns the cosine of the argument. The
argument should be an angle expressed in radians. The return type is
double
.
Example:
a = cos(m);
exit(status)
Header File:
cstdlib
Description:
Accepts an
int
argument. Terminates the program and passes the value
of the argument to the operating system.
Example:
exit(0);
exp(m)
Header File:
cmath
Description:
Accepts a
double
argument. Computes the exponential function of the
argument, which is e
x
. The return type is
double
.
Example:
a = exp(m);
fmod(m, n)
Header File:
cmath
Description:
Accepts two
double
arguments. Returns, as a
double
, the remainder of
the first argument divided by the second argument. Works like the
modulus operator, but the arguments are doubles. (The modulus operator
only works with integers.) Take care not to pass zero as the second
argument. Doing so would cause division by zero.
Example:
a = fmod(m, n);
isalnum(ch)
Header File:
cctype
Description:
Accepts a
char
argument. Returns true if the argument is a letter of the
alphabet or a digit. Otherwise, it returns false.
Example:
if (isalnum(ch))
cout << ch << " is alphanumeric.\n";
isdigit(ch)
Header File:
cctype
Description:
Accepts a
char
argument. Returns true if the argument is a digit 0 - 9.
Otherwise, it returns false.
Example:
if (isdigit(ch))
cout << ch << " is a digit.\n";
Table I-1 Alphabetical Listing of Selected Library Functions
(continued)
Function Details
Appendix I: Header File and Library Function Reference
3
islower(ch)
Header File:
cctype
Description:
Accepts a
char
argument. Returns true if the argument is a lowercase
letter. Otherwise, it returns false.
Example:
if (islower(ch))
cout << ch << " is lowercase.\n";
isprint(ch)
Header File:
cctype
Description:
Accepts a
char
argument. Returns true if the argument is a printable
character (including a space). Returns false otherwise.
Example:
if (isprint(ch))
cout << ch << " is printable.\n";
ispunct(ch)
Header File:
cctype
Description:
Accepts a
char
argument. Returns true if the argument is a printable
character other than a digit, letter, or space. Returns false otherwise.
Example:
if (ispunct(ch))
cout << ch << " is punctuation.\n";
isspace(ch)
Header File:
cctype
Description:
Accepts a
char
argument. Returns true if the argument is a whitespace
character. Whitespace characters are any of the following:
• space................ ‘ ’
• newline.............. ‘\n’
• tab.................. ‘\t’
• vertical tab......... ‘\v’
Otherwise, it returns false.
Example:
if (isspace(ch))
cout << ch << " is whitespace.\n";
isupper(ch)
Header File:
cctype
Description:
Accepts a
char
argument. Returns true if the argument is an uppercase
letter. Otherwise, it returns false.
Example:
if (isupper(ch))
cout << ch << " is uppercase.\n";
log(m)
Header File:
cmath
Description:
Accepts a
double
argument. Returns, as a
double
, the natural logarithm
of the argument.
Example:
a = log(m);
Table I-1 Alphabetical Listing of Selected Library Functions
(continued)
Function Details
4
Appendix I: Header File and Library Function Reference
log10(m)
Header File:
cmath
Description:
Accepts a double argument. Returns, as a double, the base-10 logarithm
of the argument.
Example:
a = log10(m);
pow(m, n) Header File: cmath
Description:
Accepts two double arguments. Returns the value of argument 1 raised
to the power of argument 2.
Example:
a = pow(m, n);
rand() Header File: cstdlib
Description:
Generates a pseudorandom number.
Example:
x = rand();
sin(m) Header File: cmath
Description:
Accepts a double argument. Returns, as a double, the sine of the
argument. The argument should be an angle expressed in radians.
Example:
a = sin(m);
sqrt(m) Header File: cmath
Description:
Accepts a double argument. Returns, as a double, the square root of the
argument.
Example:
a = sqrt(m);
srand(m) Header File: cstdlib
Description:
Accepts an unsigned int argument. The argument is used as a seed
value to randomize the results of the rand() function.
Example:
srand(m);
strcat(str1, str2) Header File: cstring
Description:
Accepts two C-strings as arguments. The function appends the contents
of the second string to the first string. (The first string is altered; the
second string is left unchanged.)
Example:
strcat(string1, string2);
Table I-1 Alphabetical Listing of Selected Library Functions (continued)
Function Details
Appendix I: Header File and Library Function Reference 5
strcmp(str1, str2) Header File: cstring
Description:
Accepts pointers to two string arguments. If string1 and string2 are the
same, this function returns 0. If string2 is alphabetically greater than
string1, it returns a positive number. If string2 is alphabetically less than
string1, it returns a negative number.
Example:
if (strcmp(string1, string2) == 0)
cout << "The strings are equal.\n";
strcpy(str1, str2) Header File: cstring
Description:
Accepts two C-strings as arguments. The function copies the second
string to the first string. The second string is left unchanged.
Example:
strcpy(string1, string2);
strlen(str) Header File: cstring
Description:
Accepts a C-string as an argument. Returns the length of the string (not
including the null terminator).
Example:
len = strlen(name);
strncpy(str1, str2, n) Header File: cstring
Description:
Accepts two C-strings and an integer argument. The third argument, an
integer, indicates how many characters to copy from the second string to
the first string. If string2 has fewer than n characters, string1 is padded
with ‘\0’ characters.
Example:
strncpy(string1, string2, n);
strstr(str1, str2) Header File: cstring
Description:
Searches for the first occurrence of string2 in string1. If an occurrence of
string2 is found, the function returns a pointer to it. Otherwise, it returns
a NULL pointer (address 0).
Example:
cout << strstr(string1, string2);
tan(m) Header File: cmath
Description:
Accepts a double argument. Returns, as a double, the tangent of the
argument. The argument should be an angle expressed in radians.
Example:
a = tan(m);
Table I-1 Alphabetical Listing of Selected Library Functions (continued)
Function Details
6 Appendix I: Header File and Library Function Reference
tolower(ch) Header File: cctype
Description:
Accepts a char argument. Returns the lowercase equivalent of its
argument.
Example:
ch = tolower(ch);
toupper(ch) Header File: cctype
Description:
Accepts a char argument. Returns the uppercase equivalent of its
argument.
Example:
ch = toupper(ch);
Table I-2 Selected cstdlib functions
Function Details
atof(str) Header File: cstdlib
Description:
Accepts a C-string as an argument. The function converts the string to a
double and returns that value.
Example:
num = atof("3.14159");
atoi(str) Header File: cstdlib
Description:
Accepts a C-string as an argument. The function converts the string to an
int and returns that value.
Example:
num = atoi("4569");
atol(str) Header File: cstdlib
Description:
Accepts a C-string as an argument. The function converts the string to a
long and returns that value.
Example:
num = atol("5000000");
exit(status) Header File: cstdlib
Description:
Accepts an int argument. Terminates the program and passes the value
of the argument to the operating system.
Example:
exit(0);
Table I-1 Alphabetical Listing of Selected Library Functions (continued)
Function Details
Appendix I: Header File and Library Function Reference 7
rand() Header File: cstdlib
Description:
Generates a pseudorandom number.
Example:
x = rand();
srand(m) Header File: cstdlib
Description:
Accepts an unsigned int argument. The argument is used as a seed
value to randomize the results of the rand() function.
Example:
srand(m);
Table I-3 Selected cmath Functions
Function Details
abs(m) Header File: cmath
Description:
Accepts an integer argument. Returns the absolute value of the argument
as an integer.
Example:
a = abs(m);
cos(m) Header File: cmath
Description:
Accepts a double argument. Returns the cosine of the argument. The
argument should be an angle expressed in radians. The return type is
double.
Example:
a = cos(m);
exp(m) Header File: cmath
Description:
Accepts a double argument. Computes the exponential function of the
argument, which is ex. The return type is double.
Example:
a = exp(m);
fmod(m, n) Header File: cmath
Description:
Accepts two double arguments. Returns, as a double, the remainder of
the first argument divided by the second argument. Works like the
modulus operator, but the arguments are doubles. (The modulus operator
only works with integers.) Take care not to pass zero as the second
argument. Doing so would cause division by zero.
Example:
a = fmod(m, n);
Table I-2 Selected cstdlib functions (continued)
Function Details
8 Appendix I: Header File and Library Function Reference
log(m) Header File: cmath
Description:
Accepts a double argument. Returns, as a double, the natural logarithm
of the argument.
Example:
a = log(m);
log10(m) Header File: cmath
Description:
Accepts a double argument. Returns, as a double, the base-10 logarithm
of the argument.
Example:
a = log10(m);
pow(m, n) Header File: cmath
Description:
Accepts two double arguments. Returns the value of argument 1 raised
to the power of argument 2.
Example:
a = pow(m, n);
sin(m) Header File: cmath
Description:
Accepts a double argument. Returns, as a double, the sine of the
argument. The argument should be an angle expressed in radians.
Example:
a = sin(m);
sqrt(m) Header File: cmath
Description:
Accepts a double argument. Returns, as a double, the square root of the
argument.
Example:
a = sqrt(m);
tan(m) Header File: cmath
Description:
Accepts a double argument. Returns, as a double, the tangent of the
argument. The argument should be an angle expressed in radians.
Example:
a = tan(m);
Table I-3 Selected cmath Functions (continued)
Function Details
Appendix I: Header File and Library Function Reference 9
Table I-4 Selected cstring Functions
Function Details
strcat(str1, str2) Header File: cstring
Description:
Accepts two C-strings as arguments. The function appends the contents
of the second string to the first string. (The first string is altered; the
second string is left unchanged.)
Example:
strcat(string1, string2);
strcmp(str1, str2) Header File: cstring
Description:
Accepts pointers to two string arguments. If string1 and string2 are the
same, this function returns 0. If string2 is alphabetically greater than
string1, it returns a positive number. If string2 is alphabetically less than
string1, it returns a negative number.
Example:
if (strcmp(string1, string2) == 0)
cout << "The strings are equal.\n";
strcpy(str1, str2) Header File: cstring
Description:
Accepts two C-strings as arguments. The function copies the second
string to the first string. The second string is left unchanged.
Example:
strcpy(string1, string2);
strlen(str) Header File: cstring
Description:
Accepts a C-string as an argument. Returns the length of the string (not
including the null terminator)
Example:
len = strlen(name);
strncpy(str1, str2, n) Header File: cstring
Description:
Accepts two C-strings and an integer argument. The third argument, an
integer, indicates how many characters to copy from the second string to
the first string. If string2 has fewer than n characters, string1 is padded
with ‘\0’ characters.
Example:
strncpy(string1, string2, n);
strstr(str1, str2) Header File: cstring
Description:
Searches for the first occurrence of string2 in string1. If an occurrence of
string2 is found, the function returns a pointer to it. Otherwise, it returns
a NULL pointer (address 0).
Example:
cout << strstr(string1, string2);
10 Appendix I: Header File and Library Function Reference
Table I-5 Selected cctype Functions
Function Details
isalnum(ch) Header File: cctype
Description:
Accepts a char argument. Returns true if the argument is a letter of the
alphabet or a digit. Otherwise, it returns false.
Example:
if (isalnum(ch))
cout << ch << " is alphanumeric.\n";
isdigit(ch) Header File: cctype
Description:
Accepts a char argument. Returns true if the argument is a digit 0 - 9.
Otherwise, it returns false.
Example:
if (isdigit(ch))
cout << ch << " is a digit.\n";
islower(ch) Header File: cctype
Description:
Accepts a char argument. Returns true if the argument is a lowercase
letter. Otherwise, it returns false.
Example:
if (islower(ch))
cout << ch << " is lowercase.\n";
isprint(ch) Header File: cctype
Description:
Accepts a char argument. Returns true if the argument is a printable
character (including a space). Returns false otherwise.
Example:
if (isprint(ch))
cout << ch << " is printable.\n";
ispunct(ch) Header File: cctype
Description:
Accepts a char argument. Returns true if the argument is a printable
character other than a digit, letter, or space. Returns false otherwise.
Example:
if (ispunct(ch))
cout << ch << " is punctuation.\n";
isspace(ch) Header File: cctype
Description:
Accepts a char argument. Returns true if the argument is a whitespace
character. Whitespace characters are any of the following:
• space................ ‘ ’
• newline.............. ‘\n’
• tab.................. ‘\t’
• vertical tab......... ‘\v’
Otherwise, it returns false.
Example:
if (isspace(ch))
cout << ch << " is whitespace.\n";
Appendix I: Header File and Library Function Reference 11
isupper(ch) Header File: cctype
Description:
Accepts a char argument. Returns true if the argument is an uppercase
letter. Otherwise, it returns false.
Example:
if (isupper(ch))
cout << ch << " is uppercase.\n";
tolower(ch) Header File: cctype
Description:
Accepts a char argument. Returns the lowercase equivalent of its
argument.
Example:
ch = tolower(ch);
toupper(ch) Header File: cctype
Description:
Accepts a char argument. Returns the uppercase equivalent of its
argument.
Example:
ch = toupper(ch);
Table I-5 Selected cctype Functions (continued)
Function Details

Program code for Ada, 4th Edition

Chapter 2 Ada Concepts
2.2 Overall structure
with Sqrt, Simple_IO;
procedure Print_Root is
use Simple_IO;
begin
Put(Sqrt(2.5));
end Print_Root;
----
with Sqrt, Simple_IO;
procedure Print_Root is
use Simple_IO;
X: Float;
begin
Get(X);
Put(Sqrt(X));
end Print_Root;
----
with Sqrt, Simple_IO;
procedure Print_Roots is
use Simple_IO;
X: Float;
begin
Put("Roots of various numbers");
New_Line(2);
loop
Get(X);
exit when X = 0.0;
Put(" Root of ");
Put(X);
Put(" is ");
if X < 0.0 then
Put("not calculable");
else
Put(Sqrt(X));
end if;
New_Line;
end loop;
New_Line;
Put("Program finished");
New_Line;
end Print_Roots;
----
function Sqrt(F: Float) return Float is
R: Float;
begin
-- compute value of Sqrt(F) in R
return R;
end Sqrt;
----
package Simple_IO is
procedure Get(F: out Float);
procedure Put(F: in Float);
procedure Put(S: in String);
procedure New_Line(N: in Integer := 1);
end Simple_IO;
----
with Text_IO;
package body Simple_IO is
...
procedure Get(F: out Float) is
...
begin
...
end Get;
-- other procedures similarly
end Simple_IO;
2.3 Errors and exceptions
if X < 0.0 then
Put("not calculable");
else
Put(Sqrt(X));
end if;
----
begin
Put(Sqrt(X));
exception
when Constraint_Error =>
Put("not calculable");
end;
2.4 The type model
declare
type Colour is (Red, Amber, Green);
type Fish is (Cod, Hake, Plaice);
X, Y: Colour;
A, B: Fish;
begin
X := Red; -- ok
A := Hake; -- ok
B := X; -- illegal
...
end;
----
declare
type Light is new Colour;
C: Colour;
L: Light;
begin
L := Amber; -- the light amber, not the colour
C := Colour(L); -- explicit conversion
...
end;
2.5 Generics
generic
type Num is digits <>;
package Float_IO is
...
procedure Get(Item: out Num; ... );
procedure Put(Item: in Num; ... );
...
end Float_IO;
----
with Elementary_Functions_Exceptions;
generic
type Float_Type is digits <>;
package Generic_Elementary_Functions is
function Sqrt(X: Float_Type) return Float_Type;
... -- and so on
end;
2.6 Input-output
with IO_Exceptions;
package Text_IO is
type Count is ... -- an integer type
...
procedure New_Line(Spacing: in Count := 1);
procedure Set_Col(To: in Count);
function Col return Count;
...
procedure Get(Item: out Character);
procedure Put(Item: in Character);
procedure Put(Item: in String);
...
-- the package Float_IO outlined in the previous section
-- plus a similar package Integer_IO
...
end Text_IO;
----
C: Character;
...
Put("Do you want to stop? Answer Y if so. ");
Get(C);
if C = 'Y' then
...
2.7 Running a program
with Text_IO, Generic_Elementary_Functions;
procedure Print_Roots is
type Real is digits 7;
X: Real;
use Text_IO;
package Real_IO is new Float_IO(Real);
use Real_IO;
package Real_Maths is
new Generic_Elementary_Functions(Real);
use Real_Maths;
begin
Put("Roots of various numbers");
...
... -- and so on as before
...
end Print_Roots;
----
with Text_IO, Generic_Elementary_Functions;
package Etc is
type Real is digits 7;
package Real_IO is new Text_IO.Float_IO(Real);
package Int_IO is new Text_IO.Integer_IO(Integer);
package Real_Maths is
new Generic_Elementary_Functions(Real);
end Etc;
----
with Text_IO, Etc;
use Text_IO, Etc;
procedure Program is
use Real_IO, Int_IO, Real_Maths; -- as required
...
...
end Program;
Chapter 4 Scalar Types
4.2 Blocks and scopes
declare
I: Integer := 0; -- declarations here
begin
I := I+1; -- statements here
end;
----
declare
I, J: Integer;
begin
... -- here I is the outer one
declare
I: Integer;
begin
... -- here I is the inner one
end;
... -- here I is the outer one
end;
----
declare
I: Integer := 0;
begin
...
declare
K: Integer := I;
I: Integer := 0;
begin
...
end;
...
end;
Exercise 4.2
declare
I: Integer := 7;
J, K: Integer
begin
J := I+K;
declare
P: Integer=I;
I, J: Integer;
begin
I := P+Q;
J := P-Q;
K := I*J;
end;
Put(K); -- output value of K
end;
4.6 Enumeration types
type Colour is (Red, Amber, Green);
type Day is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);
type Stone is (Amber, Beryl, Quartz);
type Groom is (Tinker, Tailor, Soldier, Sailor,
Rich_Man, Poor_Man, Beggar_Man, Thief);
type Solo is (Alone);
Chapter 5 Control Structures
5.1 If statements
if Hungry then
Cook;
Eat;
Wash_Up;
end if;
----
if Today = Sun then
Tomorrow := Mon;
else
Tomorrow := Day'Succ(Today);
end if;
----
if A = 0.0 then
-- linear case
else
if B**2 - 4.0*A*C >= 0.0 then
-- real roots
else
-- complex roots
end if;
end if;
----
if A = 0.0 then
-- linear case
elsif B**2 - 4.0*A*C >= 0.0 then
-- real roots
else
-- complex roots
end if;
----
if Order = Left then
Turn_Left;
else
if Order = Right then
Turn_Right;
else
if Order = Back then
Turn_Back;
end if;
end if;
end if;
----
if Order = Left then
Turn_Left;
elsif Order = Right then
Turn_Right;
elsif Order = Back then
Turn_Back;
end if;
5.2 Case statements
case Order is
when Left => Turn_Left;
when Right => Turn_Right;
when Back => Turn_Back;
when On => null;
end case;
----
case Today is
when Mon Tues Wed Thu => Work;
when Fri => Work; Party;
when Sat Sun => null;
end case;
----
case Today is
when Mon .. Thu => Work;
when Fri => Work; Party;
when others => null;
end case;
----
case Today is
when Weekday => Work;
if Today = Fri then
Party;
end if;
when others => null;
end case;
----
case Weekday'(Today) is
when Mon .. Thu => Work;
when Fri => Work; Party;
end case;
5.3 Loop statements
loop
Work;
Eat;
Sleep;
end loop;
----
declare
E: Real := 1.0;
I: Integer := 0;
Term: Real := 1.0;
begin
loop
I := I + 1;
Term := Term / Real(I);
E := E + Term;
end loop;
...
----
loop
if I = N then exit; end if;
I := I + 1;
Term := Term / Real(I);
E := E + Term;
end loop;
----
loop
exit when I = N;
I := I + 1;
Term := Term / Real(I);
E := E + Term;
end loop;
----
while I /= N loop
I := I + 1;
Term := Term / Real(I);
E := E + Term;
end loop;
----
for I in 1 .. N loop
Term := Term / Real(I);
E := E + Term;
end loop;
----
for I in 1 .. N loop
for J in 1 .. M loop
-- if values of I and J satisfy
-- some condition then leave nested loop
end loop;
end loop;
----
Search:
for I in 1 .. N loop
for J in 1 .. M loop
if condition_OK then
I_Value := I;
J_Value := J;
exit Search;
end if;
end loop;
end loop Search;
-- control passes here
Chapter 6 Composite Types
6.1 Arrays
for I in A'Range loop
A(I) := 0.0;
end loop;
for I in AA'Range(1) loop
for J in AA'Range(2) loop
AA(I, J) := 0.0;
end loop;
end loop;
6.3 Array aggregates
type Event is (Birth, Accession, Death);
type Monarch is (William_I, William_II, Henry_I, ... ,
Victoria, Edward_VII, George_V, ... );
...
Royal_Events: constant array (Monarch, Event) of Integer
:= (William_I => (1027, 1066, 1087),
William_II => (1056, 1087, 1100),
Henry_I => (1068, 1100, 1135),
...
Victoria => (1819, 1837, 1901),
Edward_VII => (1841, 1901, 1910),
George_V => (1865, 1910, 1936),
... );
6.5 Arrays of arrays and slices
Zoo: constant String_Array := ("aardvark",
"baboon ",
"camel ",
"dolphin ",
"elephant",
...
"zebra ");
6.6 One-dimensional array operations
White: constant Colour := (F, F, F);
Red: constant Colour := (T, F, F);
Yellow: constant Colour := (F, T, F);
Blue: constant Colour := (F, F, T);
Green: constant Colour := (F, T, T);
Purple: constant Colour := (T, F, T);
Orange: constant Colour := (T, T, F);
Black: constant Colour := (T, T, T);
6.7 Records
type Month_Name is (Jan, Feb, Mar, Apr, May, Jun, Jul,
Aug, Sep, Oct, Nov, Dec);
type Date is
record
Day: Integer range 1 .. 31;
Month: Month_Name;
Year: Integer;
end record;
Chapter 7 Subprograms
7.1 Functions
function Sqrt(X: Real) return Real is
R: Real;
begin
-- compute value of Sqrt(X) in R
return R;
end Sqrt;
----
function Sign(X: Integer) return Integer is
begin
if X > 0 then
return +1;
elsif X < 0 then
return -1;
else
return 0;
end if;
end Sign;
----
function Factorial(N: Positive) return Positive is
begin
if N = 1 then
return 1;
else
return N * Factorial(N-1);
end if;
end Factorial;
----
function Sum(A: Vector) return Real is
Result: Real := 0.0;
begin
for I in A'Range loop
Result := Result + A(I);
end loop;
return Result;
end Sum;
----
function Inner(A, B: Vector) return Real is
Result: Real := 0.0;
begin
for I in A'Range loop
Result := Result + A(I)*B(I);
end loop;
return Result;
end Inner;
----
function Rev(X: Vector) return Vector is
R: Vector(X'Range);
begin
for I in X'Range loop
R(I) := X(X'First+X'Last-I);
end loop;
return R;
end Rev;
7.2 Operators
function "*" (A, B: Vector) return Real is
Result: Real := 0.0;
begin
for I in A'Range loop
Result := Result + A(I)*B(I);
end loop;
return Result;
end "*";
----
function "+" (A: Vector) return Real is
Result: Real := 0.0;
begin
for I in A'Range loop
Result := Result + A(I);
end loop;
return Result;
end "+";
7.3 Procedures
declare
A: constant Integer := 2+P; -- in
B: constant Integer := 37; -- in
C: Integer; -- out
begin
C := A+B; -- body
Q := C; -- out
end;
----
declare
X: Integer := I;
begin
X := X+1;
I := X;
end;
----
I: Integer;
A: array (1 .. 10) of Integer;
procedure Silly(X: in out Integer) is
begin
I := I+1;
X := X+1;
end;
----
procedure Quadratic(A, B, C: in Real; Root_1, Root_2:
out Real; OK: out Boolean) is
D: constant Real := B**2 - 4.0*A*C;
begin
if D < 0.0 or A = 0.0 then
OK := False;
return;
end if;
Root_1 := (-B+Sqrt(D)) / (2.0*A);
Root_2 := (-B-Sqrt(D)) / (2.0*A);
OK := True;
end Quadratic;
----
declare
L, M, N: Real;
P, Q: Real;
Status: Boolean;
begin
-- sets values into L, M and N
Quadratic(L, M, N, P, Q, Status);
if Status then
-- roots are in P and Q
else
-- fails
end if;
end;
----
begin
OK := D >= 0.0 and A /= 0.0;
if not OK then
return;
end if;
Root_1 := ... ;
Root_2 := ... ;
end Quadratic;
Exercise 7.3
A: Vector(1 .. 1);
procedure P(V: Vector) is
begin
A(1) := V(1)+V(1);
A(1) := V(1)+V(1);
end;
...
A(1) := 1.0;
P(A);
7.6 Declarations, scopes and visibility
procedure F( ... ); -- declaration of F
procedure G( ... ) is -- body of G
begin
F( ... );
end G;
procedure F( ... ) is -- body of F repeats
begin -- its specification
G( ... );
end F;
----
procedure P is
I: Integer := 0;
procedure Q is
K: Integer := I;
I: Integer;
J: Integer;
begin
...
end Q;
begin
...
end P;
----
Outer:
declare
I: Integer := 0;
begin
...
declare
K: Integer := I;
I: Integer;
J: Integer := Outer.I;
begin
...
end;
end Outer;
----
L:
for I in AA'Range(1) loop
for I in AA'Range(2) loop
AA(L.I, I) := 0.0;
end loop;
end loop L;
Chapter 8 Overall Structure
8.1 Packages
procedure Push(X: Integer) is
begin
Top := Top+1;
S(Top) := X;
end Push;
function Pop return Integer is
begin
Top := Top-1;
return S(Top+1);
end Pop;
----
package Stack is -- specification
procedure Push(X: Integer);
function Pop return Integer;
end Stack;
package body Stack is -- body
Max: constant := 100;
S: array (1 .. Max) of Integer;
Top: Integer range 0 .. Max;
procedure Push(X: Integer) is
begin
Top := Top+1;
S(Top) := X;
end Push;
function Pop return Integer is
begin
Top := Top-1;
return S(Top+1);
end Pop;
begin -- initialization
Top := 0;
end Stack;
----
declare
package Stack is -- specification
... -- and
... -- body
end Stack;
begin
...
Stack.Push(M);
...
N := Stack.Pop;
...
end;
----
declare
use Stack;
begin
...
Push(M);
...
N := Pop;
...
end;
----
package Diurnal is
type Day is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);
subtype Weekday is Day range Mon .. Fri;
Tomorrow: constant array (Day) of Day
:= (Tue, Wed, Thu, Fri, Sat, Sun, Mon);
Next_Work_Day: constant array (Weekday) of Weekday
:= (Tue, Wed, Thu, Fri, Mon);
end Diurnal;
8.2 Library units
package Stack is
...
end Stack;
package body Stack is
...
end Stack;
----
with Stack;
procedure Main is
use Stack;
M, N: Integer;
begin
...
Push(M);
...
N := Pop;
...
end Main;
8.3 Subunits
package body Stack is
Max: constant := 100;
S: array (1 .. Max) of Integer;
Top: Integer range 0 .. Max;
procedure Push(X: Integer) is separate; -- stub
function Pop return Integer is separate; -- stub
begin
Top := 0;
end Stack;
----
separate (Stack)
procedure Push(X: Integer) is
begin
Top := Top+1;
S(Top) := X;
end Push;
8.4 Scope and visibility
declare
type R is
record
I: Integer;
end record;
type S is
record
I: Integer;
end record;
AR: R;
AS: S;
I: Integer;
begin
...
I := AR.I+AS.I; -- legal
...
end;
----
package P1 is
package P2 is
...
end P2;
...
end P1;
8.5 Renaming
declare
procedure S_Push(X: Integer) renames Stack.Push;
function S_Pop return Integer renames Stack.Pop;
begin
...
S_Push(M);
...
N := S_Pop;
...
end;
----
for I in People'Range loop
Put(People(I).Birth.Day); Put(":");
Put(Month_Name'Pos(People(I).Birth.Month)+1);
Put(":");
Put(People(I).Birth.Year);
end loop;
----
for I in People'Range loop
declare
D: Date renames People(I).Birth;
begin
Put(D.Day); Put(":");
Put(Month_Name'Pos(D.Month)+1);
Put(":");
Put(D.Year);
end;
end loop;
Chapter 9 Private Types
9.1 Normal private types
package Complex_Numbers is
type Complex is
record
Rl, Im: Real;
end record;
I: constant Complex := (0.0, 1.0);
function "+" (X: Complex) return Complex; -- unary +
function "-" (X: Complex) return Complex; -- unary -
function "+" (X, Y: Complex) return Complex;
function "-" (X, Y: Complex) return Complex;
function "*" (X, Y: Complex) return Complex;
function "/" (X, Y: Complex) return Complex;
end;
----
package Complex_Numbers is
type Complex is private;
I: constant Complex;
function "+" (X: Complex) return Complex;
function "-" (X: Complex) return Complex;
function "+" (X, Y: Complex) return Complex;
function "-" (X, Y: Complex) return Complex;
function "*" (X, Y: Complex) return Complex;
function "/" (X, Y: Complex) return Complex;
function Cons(R, I: Real) return Complex;
function Rl_Part(X: Complex) return Real;
function Im_Part(X: Complex) return Real;
private
type Complex is
record
Rl, Im: Real;
end record;
I: constant Complex := (0.0, 1.0);
end;
----
package body Complex_Numbers is
-- unary + -
function "+" (X, Y: Complex) return Complex is
begin
return (X.Rl + Y.Rl, X.Im + Y.Im);
end "+";
-- plus - * / similarly
function Cons(R, I: Real) return Complex is
begin
return (R, I);
end Cons;
function Rl_Part(X: Complex) return Real is
begin
return X.Rl;
end Rl_Part;
-- Im_Part similarly
end Complex_Numbers;
----
declare
use Complex_Numbers;
C, D: Complex;
R, S: Real;
begin
C := Cons(1.5, -6.0);
D := C + I; -- Complex +
R := Rl_Part(D) + 6.0; -- Real +
...
end;
----
private
Pi: constant := 3.14159_26536;
type Complex is
record
R: Real;
Theta: Real range 0.0 .. 2.0*Pi;
end record;
I: constant Complex := (1.0, 0.5*Pi);
end;
Exercise 9.1
package Rational_Numbers is
type Rational is private;
function "+" (X: Rational) return Rational; -- unary +
function "-" (X: Rational) return Rational; -- unary -
function "+" (X, Y: Rational) return Rational;
function "-" (X, Y: Rational) return Rational;
function "*" (X, Y: Rational) return Rational;
function "/" (X, Y: Rational) return Rational;
function "/" (X: Integer; Y: Positive) return Rational;
function Numerator(R: Rational) return Integer;
function Denominator(R: Rational) return Positive;
private
...
end;
9.2 Limited private types
package Stacks is
type Stack is limited private;
procedure Push(S: in out Stack; X: in Integer);
procedure Pop(S: in out Stack; X: out Integer);
function "=" (S, T: Stack) return Boolean;
private
Max: constant := 100;
type Integer_Vector is array (Integer range <>) of Integer;
type Stack is
record
S: Integer_Vector(1 .. Max);
Top: Integer range 0 .. Max := 0;
end record;
end;
----
package body Stacks is
procedure Push(S: in out Stack; X: in Integer) is
begin
S.Top := S.Top+1;
S.S(S.Top) := X;
end Push;
procedure Pop(S: in out Stack; X: out Integer) is
begin
X := S.S(S.Top);
S.Top := S.Top-1;
end Pop;
function "=" (S, T: Stack) return Boolean is
begin
if S.Top /= T.Top then
return False;
end if;
for I in 1 .. S.Top loop
if S.S(I) /= T.S(I) then
return False;
end if;
end loop;
return True;
end "=";
end Stacks;
----
declare
use Stacks;
St: Stack;
Empty: Stack;
...
begin
Push(St, N);
...
Pop(St, M);
...
if St = Empty then
...
end if;
...
end;
9.3 Resource management
package Key_Manager is
type Key is limited private;
procedure Get_Key(K: in out Key);
procedure Return_Key(K: in out Key);
function Valid(K: Key) return Boolean;
...
procedure Action(K: in Key; ... );
...
private
Max: constant := 100; -- number of keys
subtype Key_Code is Integer range 0 .. Max;
type Key is
record
Code: Key_Code := 0;
end record;
end;
package body Key_Manager is
Free: array (Key_Code range 1 .. Key_Code'Last) of
Boolean := (others => True);
function Valid(K: Key) return Boolean is
begin
return K.Code /= 0;
end Valid;
procedure Get_Key(K: in out Key) is
begin
if K.Code = 0 then
for I in Free'Range loop
if Free(I) then
Free(I) := False;
K.Code := I;
return;
end if;
end loop;
-- all keys in use
end if;
end Get_Key;
procedure Return_Key(K: in out Key) is
begin
if K.Code /= 0 then
Free(K.Code) := True;
K.Code := 0;
end if;
end Return_Key;
...
procedure Action(K: in Key; ... ) is
begin
if Valid(K) then
...
end Action;
end Key_Manager;
----
declare
use Key_Manager;
My_Key: Key;
begin
...
Get_Key(My_Key);
...
Action(My_Key, ... );
...
Return_Key(My_Key);
...
end;
Exercise 9.3
package Bank is
subtype Money is Natural;
type Key is limited private;
procedure Open_Account(K: in out Key; M: in Money);
-- open account with initial deposit M
procedure Close_Account(K: in out Key; M: out Money);
-- close account and return balance
procedure Deposit(K: in Key; M: in Money);
-- deposit amount M
procedure Withdraw(K: in out Key; M in out Money);
-- withdraw amount M; if account does not contain M
-- then return what is there and close account
function Statement(K: Key) return Money;
-- returns a statement of current balance
function Valid(K: Key) return Boolean;
-- checks the key is valid
private
...
----
declare
use Key_Manager;
My_Key: Key;
procedure Cheat(Copy: in out Key) is
begin
Return_Key(My_Key);
Action(Copy, ... );
...
end;
begin
Get_Key(My_Key);
Cheat(My_Key);
...
end;
----
declare
use Key_Manager;
My_Key: Key;
procedure Destroy(K: out Key) is
begin
null;
end;
begin
Get_Key(My_Key);
Destroy(My_Key);
...
end;
Chapter 10 Exceptions
10.1 Handling exceptions
begin
-- sequence of statements
exception
when Constraint_Error =>
-- do something
end;
----
begin
Tomorrow := Day'Succ(Today);
exception
when Constraint_Error =>
Tomorrow := Day'First;
end;
----
begin
-- sequence of statements
exception
when Numeric_Error Constraint_Error =>
Put("Numeric or Constraint Error occurred");
...
when Storage_Error =>
Put("Ran out of space");
...
when others =>
Put("Something else went wrong");
...
end;
----
function Tomorrow(Today: Day) return Day is
begin
return Day'Succ(Today);
exception
when Constraint_Error =>
return Day'First;
end Tomorrow;
10.2 Declaring and raising exceptions
declare
use Stack;
begin
...
Push(M);
...
N := Pop;
...
exception
when Constraint_Error =>
-- stack manipulation incorrect?
end;
----
package Stack is
Error: exception;
procedure Push(X: Integer);
function Pop return Integer;
end Stack;
package body Stack is
Max: constant := 100;
S: array (1 .. Max) of Integer;
Top: Integer range 0 .. Max;
procedure Push(X: Integer) is
begin
if Top = Max then
raise Error;
end if;
Top := Top+1;
S(Top) := X;
end Push;
function Pop return Integer is
begin
if Top = 0 then
raise Error;
end if;
Top := Top-1;
return S(Top+1);
end Pop;
begin
Top := 0;
end Stack;
----
declare
use Stack;
begin
...
Push(M);
...
N := Pop;
...
exception
when Error =>
-- stack manipulation incorrect
when others =>
-- something else went wrong
end;
----
declare
use Stack, Key_Manager;
My_Key: Key;
procedure Clean_Up is
begin
Reset;
Return_Key(My_Key);
end;
begin
Get_Key(My_Key);
...
Push(M);
...
Action(My_Key, ... );
...
N := Pop;
...
Return_Key(My_Key);
exception
when Error =>
Put("Stack used incorrectly");
Clean_Up;
when others =>
Put("Something else went wrong");
Clean_Up;
end;
----
procedure Reset is
Junk: Integer;
use Stack;
begin
loop
Junk := Pop;
end loop;
exception
when Error =>
null;
end Reset;
----
exception
when Error =>
Put("Stack used incorrectly");
Clean_Up;
raise Another_Error;
when others =>
...
end;
----
declare
use Stack;
OK: Boolean;
begin
...
Push(M, OK);
if not OK then ... end if;
...
Pop(N, OK);
if not OK then ... end if;
end;
10.3 Checking and exceptions
...
S: array (1 .. Max) of Integer;
Top: Integer range 0 .. Max;
procedure Push(X: Integer) is
begin
Top := Top+1;
S(Top) := X;
end Push;
----
procedure Push(X: Integer) is
begin
if Top = Max then
raise Error;
end if;
Top := Top+1;
S(Top) := X;
end Push;
10.4 Scope of exceptions
declare
procedure P is
X: exception;
begin
raise X;
end P;
begin
P;
exception
when others =>
-- X handled here
end;
----
declare
package P is
procedure F;
procedure H;
end P;
procedure G is
begin
P.H;
exception
when others =>
raise;
end G;
package body P is
X: exception;
procedure F is
begin
G;
exception
when X =>
Put("Got it!");
end F;
procedure H is
begin
raise X;
end H;
end P;
begin
P.F;
end;
----
procedure F(N: Integer) is
X: exception;
begin
if N = 0 then
raise X;
else
F(N-1);
end if;
exception
when X =>
Put("Got it!");
raise;
when others =>
null;
end F;
----
procedure Withdraw (K: in out Key; M: in out Money) is
begin
if Valid (K) then
if M > amount remaining then
M := amount remaining;
Free(K.Code) := True;
K.Code := 0;
raise Alarm;
else
...
end if;
end if;
end Withdraw;
Exercise 10.4
procedure P is
begin
P;
exception
when Storage_Error =>
P;
end P;
Chapter 11 Advanced Types
11.1 Discriminated record types
function Trace(M: Matrix) return Real is
Sum: Real := 0.0;
begin
if M'First(1) /= M'First(2) or M'Last(1) /= M'Last(2) then
raise Non_Square;
end if;
for I in M'Range loop
Sum := Sum + M(I, I);
end loop;
return Sum;
end Trace;
----
function Trace(M: Square) return Real is
Sum: Real := 0.0;
begin
for I in M.Mat'Range loop
Sum := Sum + M.Mat(I, I);
end loop;
return Sum;
end Trace;
----
function Transpose(M: Square) return Square is
R: Square(M.Order);
begin
for I in 1 .. M.Order loop
for J in 1 .. M.Order loop
R.Mat(I, J) := M.Mat(J, I);
end loop;
end loop;
return R;
end Transpose;
----
package Stacks is
type Stack(Max: Natural) is limited private;
procedure Push(S: in out Stack; X: in Integer);
procedure Pop(S: in out Stack; X out Integer);
function "=" (S, T: Stack) return Boolean;
private
type Integer_Vector is array (Integer range <>) of Integer;
type Stack(Max: Natural) is
record
S: Integer_Vector(1 .. Max);
Top: Integer := 0;
end record;
end;
11.2 Default discriminants
function Normal(P: Polynomial) return Polynomial is
Size: Integer := P.N;
begin
while Size > 0 and P.A(Size) = 0 loop
Size := Size-1;
end loop;
return (Size, P.A(0 .. Size));
end Normal;
----
subtype String_Size is Integer range 0 .. 80;
type V_String(N: String_Size := 0) is
record
S: String(1 .. N);
end record;
11.3 Variant parts
type Gender is (Male, Female);
type Person(Sex: Gender) is
record
Birth: Date;
case Sex is
when Male =>
Bearded: Boolean;
when Female =>
Children: Integer;
end case;
end record;
----
type Gender is (Male, Female, Neuter);
type Mutant(Sex: Gender := Neuter) is
record
Birth: Date;
case Sex is
when Male =>
Bearded: Boolean;
when Female =>
Children: Integer;
when Neuter =>
null;
end case;
end record;
11.4 Access Types
type Cell;
type Link is access Cell;
type Cell is
record
Value: Integer;
Next: Link;
end record;
L: Link;
----
function Sum(List: Link) return Integer is
L: Link := List;
S: Integer := 0;
begin
while L /= null loop
S := S+L.Value;
L := L.Next;
end loop;
return S;
end Sum;
----
type Node;
type Tree is access Node;
type Node is
record
Value: Real;
Left, Right: Tree;
end record;
----
procedure Sort(A: in out Vector) is
I: Integer;
Base: Tree := null;
procedure Insert(T: in out Tree; V: Real) is
begin
if T = null then
T := new Node'(V, null, null);
else
if V < T.Value then
Insert(T.Left, V);
else
Insert(T.Right, V);
end if;
end if;
end Insert;
procedure Output(T: Tree) is
begin
if T /= null then
Output(T.Left);
A(I) := T.Value;
I := I+1;
Output(T.Right);
end if;
end Output;
begin -- body of Sort
for J in A'Range loop
Insert(Base, A(J));
end loop;
I := A'First;
Output(Base);
end Sort;
11.5 Access types and private types
package Stacks is
type Stack is limited private;
procedure Push(S: in out Stack; X: in Integer);
procedure Pop(S: in out Stack; X: out Integer);
private
type Cell;
type Stack is access Cell;
type Cell is
record
Value: Integer;
Next: Stack;
end record;
end;
package body Stacks is
procedure Push(S: in out Stack; X: in Integer) is
begin
S := new Cell'(X, S);
end;
procedure Pop(S: in out Stack; X: out Integer) is
begin
X := S.Value;
S := S.Next;
end;
end Stacks;
----
function "=" (S, T: Stack) return Boolean is
SS: Stack := S;
TT: Stack := T;
begin
while SS /= null and TT /= null loop
SS := SS.Next;
TT := TT.Next;
if SS.Value /= TT.Value then
return False;
end if;
end loop;
return SS = TT; -- True if both null
end;
----
type Cell;
type Link is access Cell;
type Cell is
record
Value: Integer;
Next: Link;
end record;
type Stack is
record
List: Link;
end record;
Exercise 11.5
package Queues is
Empty: exception;
type Queue is limited private;
procedure Join(Q: in out Queue; X: in Item);
procedure Remove(Q: in out Queue; X: out Item);
function Length(Q: Queue) return Integer;
private
11.6 Access types and constraints
type Person;
type Person_Name is access Person;
type Person is
record
Sex: Gender;
Birth: Date;
Spouse: Person_Name;
Father: Person_Name;
First_Child: Person_Name;
Next_Sibling: Person_Name;
end record;
----
type Person(Sex: Gender);
type Person_Name is access Person;
type Person(Sex: Gender) is
record
Birth: Date;
Father: Person_Name(Male);
Next_Sibling: Person_Name;
case Sex is
when Male =>
Wife: Person_Name(Female);
when Female =>
Husband: Person_Name(Male);
First_Child: Person_Name;
end case;
end record;
----
procedure Marry(Bride: Womans_Name;
Groom: Mans_Name) is
begin
if Bride.Husband /= null or Groom.Wife /= null then
raise Bigamy;
end if;
Bride.Husband := Groom;
Groom.Wife := Bride;
end Marry;
----
function Spouse(P: Person_Name) return Person_Name is
begin
case P.Sex is
when Male =>
return P.Wife;
when Female =>
return P.Husband;
end case;
end Spouse;
----
function New_Child(Mother: Womans_Name;
Boy_Or_Girl: Gender; Birthday: Date)
return Person_Name is
Child: Person_Name;
begin
if Mother.Husband = null then
raise Illegitimate;
end if;
Child := new Person(Boy_Or_Girl);
Child.Birth := Birthday;
Child.Father := Mother.Husband;
declare
Last: Person_Name := Mother.First_Child;
begin
if Last = null then
Mother.First_Child := Child;
else
while Last.Next_Sibling /= null loop
Last := Last.Next_Sibling;
end loop;
Last.Next_Sibling := Child;
end if;
end;
return Child;
end New_Child;
11.7 Derived types
type Cell;
type Link is access Cell;
type Cell is
record
Value: Integer;
Next: Link;
end record;
type Stack is new Link;
----
function "=" (S, T: Stack) return Boolean is
SL: Link := Link(S);
TL: Link := Link(T);
begin
-- as the answer to Exercise 11.5(2)
end "=";
Chapter 12 Numeric Types
12.4 Fixed point types
private
Pi: constant := 3.14159_26536;
type Angle is delta 0.1 range -4*Pi .. 4*Pi;
for Angle'Small use Pi*2**(-13);
type Complex is
record
R: Real;
Theta: Angle range -Pi .. Pi;
end record;
I: constant Complex := (1.0, 0.5*Pi);
end;
----
function Normal(A: Angle) return Angle is
begin
if A >= Pi then
return A - Angle(2*Pi);
elsif A < -Pi then
return A + Angle(2*Pi);
else
return A;
end if;
end Normal;
----
package body Complex_Numbers is
function Normal ... -- as above
...
function "*" (X, Y: Complex) return Complex is
begin
return (X.R * Y.R, Normal(X.Theta + Y.Theta));
end "*";
...
function Rl_Part(X: Complex) return Real is
begin
return X.R * Cos(X.Theta);
end Rl_Part;
...
end Complex_Numbers;
Chapter 13 Generics
13.1 Declarations and instantiations
procedure Swap(X, Y: in out Real) is
T: Real;
begin
T := X; X := Y; Y := T;
end;
----
generic
type Item is private;
procedure Exchange(X, Y: in out Item);
procedure Exchange(X, Y: in out Item) is
T: Item;
begin
T := X; X := Y; Y := T;
end;
----
generic
Max: Positive;
type Item is private;
package Stack is
procedure Push(X: Item);
function Pop return Item;
end Stack;
package body Stack is
S: array (1 .. Max) of Item;
Top: Integer range 0 .. Max;
-- etc. as before but with Integer
-- replaced by Item
end Stack;
----
declare
package My_Stack is new Stack(100, Real);
use My_Stack;
begin
...
Push(X);
...
Y := Pop;
...
end;
----
generic
Max: Positive;
type Item is private;
package Stack is
Error: exception;
procedure Push(X: Item);
function Pop return Item;
end Stack;
----
package All_Stacks is
Error: exception;
generic
Max: Positive;
type Item is private;
package Stack is
procedure Push(X: Item);
function Pop return Item;
end Stack;
end All_Stacks;
package body All_Stacks is
package body Stack is
...
end Stack;
end All_Stacks;
----
generic
type Thing is private;
procedure Cab(A, B, C: in out Thing);
procedure Cab(A, B, C: in out Thing) is
procedure Swap is new Exchange(Item => Thing);
begin
Swap(A, B);
Swap(A, C);
end Cab;
13.2 Type parameters
generic
type T is (<>);
function Next(X: T) return T;
function Next(X: T) return T is
begin
if X=T'Last then
return T'First;
else
return T'Succ(X);
end if;
end Next;
----
generic
type Real is digits <>;
package Generic_Complex_Numbers is
type Complex is private;
-- as before
I: constant Complex := (0.0, 1.0);
end;
----
generic
type Index is (<>);
type Floating is digits <>;
type Vec is array (Index range <>) of Floating;
function Sum(A: Vec) return Floating;
function Sum(A: Vec) return Floating is
Result: Floating := 0.0;
begin
for I in A'Range loop
Result := Result+A(I);
end loop;
return Result;
end Sum;
----
generic
type Base is (<>);
package Set_Of is
type Set is private;
type List is array (Positive range <>) of Base;
Empty, Full: constant Set;
function Make_Set(X: List) return Set;
function Make_Set(X: Base) return Set;
function Decompose(X: Set) return List;
function "+" (X, Y: Set) return Set; -- union
function "*" (X, Y: Set) return Set; -- intersection
function "-" (X, Y: Set) return Set; -- symmetric difference
function "<" (X: Base; Y: Set) return Boolean; -- inclusion
function "<=" (X, Y: Set) return Boolean; -- contains
function Size(X: Set) return Natural; -- no of elements
private
type Set is array (Base) of Boolean;
Empty: constant Set := (Set'Range => False);
Full: constant Set := (Set'Range => True);
end;
----
generic
type Base is (<>);
type Index is (<>);
type List is array (Index range <>) of Base;
package Nice_Set_Of is
type Set is private;
function Empty return Set;
function Full return Set;
...
private
----
type Primary_List is array (Positive range <>) of Primary;
package Primary_Sets is new Nice_Set_Of(Base => Primary,
Index => Positive,
List => Primary_List);
type Colour is new Primary_Sets.Set;
13.3 Subprogram parameters
generic
type Index is (<>);
type Item is (<>);
type Collection is array (Index range <>) of Item;
procedure Sort(C: in out Collection);
----
procedure Sort(C: in out Collection) is
Min: Index;
Temp: Item;
begin
for I in C'First .. Index'Pred(C'Last) loop
Min := I;
for J in Index'Succ(I) .. C'Last loop
if C(J) < C(Min) then Min := J; end if; -- use of <
end loop;
Temp := C(I); C(I) := C(Min); C(Min) := Temp;
end loop;
end Sort;
----
generic
type Index is (<>);
type Item is private;
type Collection is array (Index range <>) of Item;
with function "<" (X, Y: Item) return Boolean;
procedure Sort(C: in out Collection);
----
procedure Reverse_Sort_Vector is
new Sort(Index => Integer,
Item => Real,
Collection => Vector,
"<" => ">");
----
subtype String_3 is String(1 .. 3);
procedure Sort_String_3_Array is
new Sort(Positive, String_3, String_3_Array, "<");
...
Sort_String_3_Array(Farmyard);
----
type Date_Array is array (Positive range <>) of Date;
function "<" (X, Y: Date) return Boolean is
begin
if X.Year /= Y.Year then
return X.Year < Y.Year;
elsif X.Month /= Y.Month then
return X.Month < Y.Month;
else
return X.Day < Y.Day;
end if;
end "<";
procedure Sort_Date_Array is
new Sort(Positive, Date, Date_Array);
----
generic
type Index is (<>);
type Item is private;
type Vec is array (Index range <>) of Item;
with function "+" (X, Y: Item) return Item;
function Apply(A: Vec) return Item;
function Apply(A: Vec) return Item is
Result: Item := A(A'First);
begin
for I in Index'Succ(A'First) .. A'Last loop
Result := Result+A(I);
end loop;
return Result;
end Apply;
----
function G(T: Real) return Real is
begin
return Exp(T)*Sin(T);
end;
function Integrate_G is new Integrate(G);
13.4 The mathematical library
with Elementary_Functions_Exceptions;
generic
type Float_Type is digits <>;
package Generic_Elementary_Functions is
function Sqrt (X: Float_Type) return Float_Type;
function Log (X: Float_Type) return Float_Type;
function Log (X, Base: Float_Type) return Float_Type;
function Exp (X: Float_Type) return Float_Type;
function "**" (Left, Right: Float_Type) return Float_Type;
function Sin (X: Float_Type) return Float_Type;
function Sin (X, Cycle: Float_Type) return Float_Type;
function Cos (X: Float_Type) return Float_Type;
function Cos (X, Cycle: Float_Type) return Float_Type;
function Tan (X: Float_Type) return Float_Type;
function Tan (X, Cycle: Float_Type) return Float_Type;
function Cot (X: Float_Type) return Float_Type;
function Cot (X, Cycle: Float_Type) return Float_Type;
function Arcsin (X: Float_Type) return Float_Type;
function Arcsin (X, Cycle: Float_Type) return Float_Type;
function Arccos (X: Float_Type) return Float_Type;
function Arccos (X, Cycle: Float_Type) return Float_Type;
function Arctan (Y: Float_Type; X: Float_Type := 1.0)
return Float_Type;
function Arctan (Y: Float_Type; X: Float_Type := 1.0;
Cycle: Float_Type) return Float_Type;
function Arccot (X: Float_Type; Y: Float_Type := 1.0)
return Float_Type;
function Arccot (X: Float_Type; Y: Float_Type := 1.0;
Cycle: Float_Type) return Float_Type;
function Sinh (X: Float_Type) return Float_Type;
function Cosh (X: Float_Type) return Float_Type;
function Tanh (X: Float_Type) return Float_Type;
function Coth (X: Float_Type) return Float_Type;
function Arcsinh (X: Float_Type) return Float_Type;
function Arccosh (X: Float_Type) return Float_Type;
function Arctanh (X: Float_Type) return Float_Type;
function Arccoth (X: Float_Type) return Float_Type;
Argument_Error: exception
renames Elementary_Functions_Exceptions.Argument_Error;
end Generic_Elementary_Functions;
----
generic
type Real_Type is digits <>;
type Complex_Type is private;
with function Cons(R, I: Real_Type) return Complex_Type is <>;
with function Cons_Polar(R, Theta: Real_Type) return
Complex_Type is <>;
with function Rl_Part(X: Complex_Type) return Real_Type is <>;
with function Im_Part(X: Complex_Type) return Real_Type is <>;
with function "abs" (X: Complex_Type) return Real_Type is <>;
with function Arg (X: Complex_Type) return Real_Type is <>;
with function Sqrt (X: Real_Type) return Real_Type is <>;
with function Log (X: Real_Type) return Real_Type is <>;
with function Exp (X: Real_Type) return Real_Type is <>;
with function Sin (X: Real_Type) return Real_Type is <>;
with function Cos (X: Real_Type) return Real_Type is <>;
with function Sinh (X: Real_Type) return Real_Type is <>;
with function Cosh (X: Real_Type) return Real_Type is <>;
package Generic_Complex_Functions is
function Sqrt(X: Complex_Type) return Complex_Type;
function Log (X: Complex_Type) return Complex_Type;
function Exp (X: Complex_Type) return Complex_Type;
function Sin (X: Complex_Type) return Complex_Type;
function Cos (X: Complex_Type) return Complex_Type;
end Generic_Complex_Functions;
----
type My_Real is digits 9;
package My_Elementary_Functions is
new Generic_Elementary_Functions(Float_Type => My_Real);
package My_Complex_Numbers is
new Generic_Complex_Numbers(Real => My_Real);
use My_Elementary_Functions, My_Complex_Numbers;
package My_Complex_Functions is
new Generic_Complex_Functions(My_Real, Complex);
use My_Complex_Functions;
Chapter 14 Tasking
14.1 Parallelism
task T is -- specification
...
end T;
task body T is -- body
...
end T;
----
procedure Shopping is
begin
Buy_Meat;
Buy_Salad;
Buy_Wine;
end;
----
procedure Shopping is
task Get_Salad;
task body Get_Salad is
begin
Buy_Salad;
end Get_Salad;
task Get_Wine;
task body Get_Wine is
begin
Buy_Wine;
end Get_Wine;
begin
Buy_Meat;
end Shopping;
14.2 The rendezvous
procedure Shopping is
task Get_Salad is
entry Pay(M: in Money);
entry Collect(S: out Salad);
end Get_Salad;
task body Get_Salad is
Cash: Money;
Food: Salad;
begin
accept Pay(M: in Money) do
Cash := M;
end Pay;
Food := Buy_Salad(Cash);
accept Collect(S: out Salad) do
S := Food;
end Collect;
end Get_Salad;
-- Get_Wine similarly
begin
Get_Salad.Pay(50);
Get_Wine.Pay(100);
MM := Buy_Meat(200);
Get_Salad.Collect(SS);
Get_Wine.Collect(WW);
end Shopping;
----
task Buffering is
entry Put(X: in Item);
entry Get(X: out Item);
end;
task body Buffering is
V: Item;
begin
loop
accept Put(X: in Item) do
V := X;
end Put;
accept Get(X: out Item) do
X := V;
end Get;
end loop;
end Buffering;
Exercise 14.2
task Build_Complex is
entry Put_Rl(X: in Real);
entry Put_Im(X: in Real);
entry Get_Comp(X: out Complex);
end;
14.3 Timing and scheduling
task Buffering is
pragma Priority(7);
entry Put ...
...
end;
----
package Calendar is
type Time is private;
subtype Year_Number is Integer range 1901 .. 2099;
subtype Month_Number is Integer range 1 .. 12;
subtype Day_Number is Integer range 1 .. 31;
subtype Day_Duration is Duration range 0.0 .. 86_400.0;
function Clock return Time;
function Year(Date: Time) return Year_Number;
function Month(Date: Time) return Month_Number;
function Day(Date: Time) return Day_Number;
function Seconds(Date: Time) return Day_Duration;
procedure Split(Date: in Time;
Year: out Year_Number;
Month: out Month_Number;
Day: out Day_Number;
Seconds: out Day_Duration);
function Time_Of(Year: Year_Number;
Month: Month_Number;
Day: Day_Number;
Seconds: Day_Duration := 0.0) return Time;
function "+" (Left: Time; Right: Duration) return Time;
function "+" (Left: Duration; Right: Time) return Time;
function "-" (Left: Time; Right: Duration) return Time;
function "-" (Left: Time; Right: Time) return Duration;
function "<" (Left, Right: Time) return Boolean;
function "<=" (Left, Right: Time) return Boolean;
function ">" (Left, Right: Time) return Boolean;
function ">=" (Left, Right: Time) return Boolean;
Time_Error: exception;
-- can be raised by Time_Of, +, and -
private
-- implementation dependent
end Calendar;
----
declare
use Calendar;
Interval: constant Duration := 5*Minutes;
Next_Time: Time := First_Time;
begin
loop
delay Next_Time - Clock;
Action;
Next_Time := Next_Time + Interval;
end loop;
end;
14.4 Simple select statements
package Protected_Variable is
procedure Read(X: out Item);
procedure Write(X: in Item);
end;
package body Protected_Variable is
V: Item;
procedure Read(X: out Item) is
begin
X := V;
end;
procedure Write(X: in Item) is
begin
V := X;
end;
begin
V := initial value;
end Protected_Variable;
----
type Item is
record
X_Coord: Real;
Y_Coord: Real;
end record;
----
task Protected_Variable is
entry Read(X: out Item);
entry Write(X: in Item);
end;
task body Protected_Variable is
V: Item;
begin
accept Write(X: in Item) do
V := X;
end;
loop
select
accept Read(X: out Item) do
X := V;
end;
or
accept Write(X: in Item) do
V := X;
end;
end select;
end loop;
end Protected_Variable;
----
task Buffering is
entry Put(X: in Item);
entry Get(X: out Item);
end;
task body Buffering is
N: constant := 8; -- for instance
A: array (1 .. N) of Item;
I, J: Integer range 1 .. N := 1;
Count: Integer range 0 .. N := 0;
begin
loop
select
when Count < n ="">
accept Put(X: in Item) do
A(I) := X;
end;
I := I mod N+1; Count := Count+1;
or
when Count > 0 =>
accept Get(X: out Item) do
X := A(J);
end;
J := J mod N+1; Count := Count-1;
end select;
end loop;
end Buffering;
----
package Reader_Writer is
procedure Read(X: out Item);
procedure Write(X: in Item);
end;
package body Reader_Writer is
V: Item;
task Control is
entry Start;
entry Stop;
entry Write(X: in Item);
end;
task body Control is
Readers: Integer := 0;
begin
accept Write(X: in Item) do
V := X;
end;
loop
select
accept Start;
Readers := Readers+1;
or
accept Stop;
Readers := Readers-1;
or
when Readers = 0 =>
accept Write(X: in Item) do
V := X;
end;
end select;
end loop;
end Control;
procedure Read(X: out Item) is
begin
Control.Start;
X := V;
Control.Stop;
end Read;
procedure Write(X: in Item) is
begin
Control.Write(X);
end Write;
end Reader_Writer;
----
select
when Write'Count = 0 =>
accept Start;
Readers := Readers+1;
or
accept Stop;
Readers := Readers-1;
or
when Readers = 0 =>
accept Write(X: in Item) do
V := X;
end;
end select;
14.5 Timed and conditional rendezvous
select
accept Read( ... ) do
...
end;
or
accept Write( ... ) do
...
end;
or
delay 10*Minutes;
-- time out statements
end select;
----
Operator.Call("Put out fire");
select
accept Acknowledge;
or
delay 1*Minutes;
Fire_Brigade.Call;
end select;
----
select
accept Read( ... ) do
...
end;
or
accept Write( ... ) do
...
end;
else
-- alternative statements
end select;
----
select
accept Acknowledge;
else
delay 1*Minutes;
Fire_Brigade.Call;
end select;
----
select
Operator.Call("Put out fire");
or
delay 1*Minutes;
Fire_Brigade.Call;
end select;
----
select
Operator.Call("Put out fire");
else
Fire_Brigade.Call;
end select;
----
procedure Write(X: in Item; T: Duration; OK: out Boolean) is
begin
select
Control.Write(X);
OK := True;
or
delay T;
OK := False;
end select;
end Write;
----
package body Reader_Writer is
V: Item;
type Service is (Read, Write);
task Control is
entry Start(S: Service);
entry Stop_Read;
entry Write;
entry Stop_Write;
end Control;
task body Control is
Readers: Integer := 0;
Writers: Integer := 0;
begin
loop
select
when Writers = 0 =>
accept Start(S: Service) do
case S is
when Read =>
Readers := Readers+1;
when Write =>
Writers := 1;
end case;
end Start;
or
accept Stop_Read;
Readers := Readers-1;
or
when Readers = 0 =>
accept Write;
or
accept Stop_Write;
Writers := 0;
end select;
end loop;
end Control;
procedure Read(X: out Item) is
begin
Control.Start(Read);
X := V;
Control.Stop_Read;
end Read;
procedure Write(X: in Item) is
begin
Control.Start(Write);
Control.Write;
V := X;
Control.Stop_Write;
end Write;
end Reader_Writer;
----
task Control is
entry Start(S: Service);
entry Stop;
end Control;
task body Control is
Readers: Integer := 0;
begin
loop
select
accept Start(S: Service) do
case S is
when Read =>
Readers := Readers+1;
when Write =>
while Readers > 0 loop
accept Stop; -- from readers
Readers := Readers-1
end loop;
end case;
end Start;
if Readers = 0 then
accept Stop; -- from the writer
end if;
or
accept Stop; -- from a reader
Readers := Readers-1;
end select;
end loop;
end Control;
procedure Read(X: out Item) is
begin
Control.Start(Read);
X := V;
Control.Stop;
end Read;
procedure Write(X: in Item) is
begin
Control.Start(Write);
V := X;
Control.Stop;
end Write;
14.6 Task types and activation
task type T is
entry E( ... );
end T;
task body T is
...
end T;
----
type Rec is
record
CT: T;
...
end record;
R: Rec;
----
declare
...
A: T;
B: T;
...
begin
...
end;
----
type R is
record
A: T;
I: Integer := E;
B: T;
end record;
----
declare
XA: T;
XI: Integer := E;
XB: T;
begin
----
task type Mailbox is
entry Deposit(X: in Item);
entry Collect(X: out Item);
end;
task body Mailbox is
Local: Item;
begin
accept Deposit(X: in Item) do
Local := X;
end;
accept Collect(X: out Item) do
X := Local;
end;
end Mailbox;
----
task Server is
entry Request(A: Address; X: Item);
end;
task body Server is
Reply: Address;
Job: Item;
begin
loop
accept Request(A: Address; X: Item) do
Reply := A;
Job := X;
end;
-- work on job
Reply.Deposit(Job);
end loop;
end Server;
task User;
task body User is
My_Box: Address := new Mailbox;
My_Item: Item;
begin
Server.Request(My_Box, My_Item);
-- do something while waiting
My_Box.Collect(My_Item);
end User;
----
select
My_Box.Collect(My_Item);
-- item collected successfully
else
-- not ready yet
end select;
----
task body Mailbox is
begin
accept Deposit(X: in Item) do
accept Collect(X: out Item) do
Collect.X := Deposit.X;
end;
end;
end Mailbox;
14.7 Termination and exceptions
task body Protected_Variable is
V: Item;
begin
accept Write(X: in Item) do
V := X;
end;
loop
select
accept Read(X: out Item) do
X := V;
end;
or
accept Write(X: in Item) do
V := X;
end;
or
terminate;
end select;
end loop;
end Protected_Variable;
----
select
T.Closedown;
or
delay 60*Seconds;
abort T;
end select;
----
select
accept Closedown;
-- tidy up and die
else
-- carry on normally
end select;
----
select
T.Closedown;
delay 10*Seconds;
or
delay 60*Seconds;
end select;
abort T;
----
accept Closedown do
loop
Put("Can't catch me");
end loop;
end;
----
task body Control is
Readers: Integer := 0;
begin
loop
select
accept Start(S: Service) do
case S is
when Read =>
Readers := Readers+1;
when Write =>
while Readers > 0 loop
accept Stop; -- from readers
Readers := Readers-1;
end loop;
end case;
end Start;
if Readers = 0 then
accept Stop; -- from the writer
end if;
or
accept Stop; -- from a reader
Readers := Readers-1;
end select;
end loop;
end Control;
----
package body Reader_Writer is
V: Item;
type Service is (Read, Write);
task type Read_Agent is
entry Read(X: out Item);
end;
type RRA is access Read_Agent;
task Control is
entry Start(S: Service);
entry Stop;
end;
task body Control is
-- as before
end Control;
task body Read_Agent is
begin
select
accept Read(X: out Item) do
Control.Start(Read);
X := V;
Control.Stop;
end;
or
terminate;
end select;
end Read_Agent;
procedure Read

Drawing Single Cube

#include
#include
#include
#include "glut.h"
GLfloat vertices[][3] = {{-1.0,-1.0,-1.0},{1.0,-1.0,-1.0},
{1.0,1.0,-1.0}, {-1.0,1.0,-1.0}, {-1.0,-1.0,1.0},
{1.0,-1.0,1.0}, {1.0,1.0,1.0}, {-1.0,1.0,1.0}};
GLfloat normals[][3] = {{-1.0,-1.0,-1.0},{1.0,-1.0,-1.0},
{1.0,1.0,-1.0}, {-1.0,1.0,-1.0}, {-1.0,-1.0,1.0},
{1.0,-1.0,1.0}, {1.0,1.0,1.0}, {-1.0,1.0,1.0}};
GLfloat colors[][3] = {{0.0,0.0,0.0},{1.0,0.0,0.0},
{1.0,1.0,0.0}, {0.0,1.0,0.0}, {0.0,0.0,1.0},
{1.0,0.0,1.0}, {1.0,1.0,1.0}, {0.0,1.0,1.0}};
void
polygon(int a, int b, int c , int d)
{
glBegin(GL_POLYGON);
glColor3fv(colors[a]);
glNormal3fv(normals[a]);
glVertex3fv(vertices[a]);
glColor3fv(colors[b]);
glNormal3fv(normals[b]);
glVertex3fv(vertices[b]);
glColor3fv(colors[c]);
glNormal3fv(normals[c]);
glVertex3fv(vertices[c]);
glColor3fv(colors[d]);
glNormal3fv(normals[d]);
glVertex3fv(vertices[d]);
glEnd();
}
void
colorcube()
{
polygon(0,3,2,1);
polygon(2,3,7,6);
polygon(0,4,7,3);
polygon(1,2,6,5);
polygon(4,5,6,7);
polygon(0,1,5,4);
}
static GLfloat theta[] = {0.0,0.0,0.0};
static GLint axis = 2;
void
display(void)
{
glClear(GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT);
glLoadIdentity();
glRotatef(theta[0], 1.0, 0.0, 0.0);
glRotatef(theta[1], 0.0, 1.0, 0.0);
glRotatef(theta[2], 0.0, 0.0, 1.0);
colorcube();
glFlush();
}
void spinCube()
{
theta[axis] += 2.0;
if( theta[axis] > 360.0 ) theta[axis] -= 360.0;
display();
}
void mouse(int btn, int state, int x, int y)
{
if(btn==GLUT_LEFT_BUTTON & state == GLUT_DOWN) axis = 0;
if(btn==GLUT_MIDDLE_BUTTON & state == GLUT_DOWN) axis = 1;
if(btn==GLUT_RIGHT_BUTTON & state == GLUT_DOWN) axis = 2;
}
void
myReshape(int w, int h)
{
glViewport(0, 0, w, h);
glMatrixMode(GL_PROJECTION);
glLoadIdentity();
if (w <= h)
glOrtho(-2.0, 2.0, -2.0 * (GLfloat) h / (GLfloat) w,
2.0 * (GLfloat) h / (GLfloat) w, -10.0, 10.0);
else
glOrtho(-2.0 * (GLfloat) w / (GLfloat) h,
2.0 * (GLfloat) w / (GLfloat) h, -2.0, 2.0, -10.0, 10.0);
glMatrixMode(GL_MODELVIEW);
}
void
main(int argc, char **argv)
{
glutInit(&argc, argv);
glutInitDisplayMode(GLUT_SINGLE GLUT_RGB GLUT_DEPTH);
glutInitWindowSize(500, 500);
glutCreateWindow("colorcube");
glutReshapeFunc(myReshape);
glutDisplayFunc(display);
glutIdleFunc(spinCube);
glutMouseFunc(mouse);
glEnable(GL_DEPTH_TEST);
glutMainLoop();
}

program has a variable

#include
using namespace std;
int main(){
int number; number = 5;
cout << "The value in number is " << number << endl;
return 0;
}

well-adjusted printing program

#include using namespace std;int main()
{
cout << "The following items were top sellers" << endl; cout << "during the month of June:" << endl; cout << "Computer games" << endl; cout << "Coffee" << endl; cout << "Aspirin" << endl; return 0;
}

printing program

// An unruly printing program
#include
using namespace std;
int main()
{
cout << "The following items were top sellers";
cout << "during the month of June:";
cout << "Computer games";
cout << "Coffee";
cout << "Aspirin";
return 0;
}

calculates the user's pay

// This progam calculates the user's pay.
#include
using namespace std;
int main()
{
double hours, rate, pay;
// Get the number of hours worked.
cout << "How many hours did you work? ";
cin >> hours;

// Get the hourly pay rate.
cout << "How much do you get paid per hour? ";
cin >> rate;

// Calculate the pay.
pay = hours * rate;

// Display the pay.
cout << "You have earned $" << pay << endl;
return 0;
}

User Authentication

/*
user.authenticate
Determine if the user blackbeard with a password of avast888 is valid.
*/

include('xmlrpc-2_1/lib/xmlrpc.inc');
include('class.RevverAPI.php');

$api = new RevverAPI('https://api.staging.revver.com/xml/1.0?login=revtester&passwd=testacct');

$username = 'blackbeard';
$password = 'avast888';

$results = $api->callRemote('user.authenticate', $username, $password);

echo '

';
var_dump($results);
echo '

';

?>

Create Video

/*
video.create
Create the metadata for video 65535.
*/

include('xmlrpc-2_1/lib/xmlrpc.inc');
include('class.RevverAPI.php');

$api = new RevverAPI('https://api.staging.revver.com/xml/1.0?login=revtester&passwd=testacct');

$id = 65535;
$title = 'My New Parrot';
$keywords = array('parrot', 'pet');
$ageRestriction = 1;
$options = array('url' => 'arrvideos.example.com', 'author' => 'Billy Doyle');

$results = $api->callRemote('video.create', $id, $title, $keywords, $ageRestriction, $options);

echo '

';
var_dump($results);
echo '

';

?>

Heap Demo project

Heap Demo is a project designed to show the relationship between virtual and committed
memory during heap use. Using a contrived scenario, a stair-step growth of virtual
memory can be observed in perfmon.

Open a new cpp file in Visual Studio. copy and paste code from this post. compile the file it will create project for u. then u can proceed further

1. Start the HeapDemo application.
2. Open perfmon.
3. Add counters for Virtual Bytes and Private Bytes for the HeapDemo Process.
4. Change the scale for each counter to 0.0000001 (lowest value).
5. Press ENTER on the console for HeapDemo to start the allocations.
6. Watch the perfmon window as memory is allocated.

Note the stair step behavior of virtual memory. Each time the private bytes nears the amount
of virtual bytes reserved, the memory manager extends the heap by reserving more virtual
memory. Each time the heap is extended, it reserves twice as much as the previous reservation.

// Tthe entry point for the console application.
//

#include
#include

void Test();

int main(int argc, char* argv[])
{
Test();

return 0;
}

void Test()
{
int nCount = 0;
int nTotal = 0;
char c;

// scanf in here only to hold process in initial loaded state to set up PerfMon.
printf("Set up Process Object's Private and Virtual Bytes for Heapdemo.exe, then hit ENTER to start the test\n");
scanf(&c);

Sleep(1000);
while(nTotal < 200000)
{
nCount++;
int (*i)[1024] = new int[100][1024];
nTotal += 100;
printf("Allocated: %d KB\n", nTotal);
Sleep(50);
}

printf("Hit any key to end the test and release all memory\n");
scanf(&c);
}

TCPDate Server / Client

This is the implementation of "System.Net.Sockets". In this example we will learn how to use the "TCPListener" and "TCPClient" classes from the "System.Net.Sockets" namespace. This example consists of two files. The "DateServer" class which uses the "TCPListener" class to accept requests from new clients. Once the client is connected with the server, the server will send it the the Current Date and Time and then disconnect it, and listen for more clients. The "DateClient" class uses the 'TCPClient" class. It connects to the server on the specified port and send the clients name to the server upon connection. Once connected it receives the current Date Time from the server and then disconnects from the server. Execution : 1) Run the DateServer.exe first to start the server .(The server by default listens for connection on port 4554). 2) Run the DateClient.exe which will connect to the server and get the current date time from it. Download The Code (TCPDate.zip)

Code:
1) DateServer.cs :- The Date Time Server

namespace SaurabhNet { using System; using System.Net.Sockets; using System.Net ; using System.Threading ; //Import the necessary Namespaces //Class which shows the implementation of the TCP Date server public class DateServer { private TCPListener myListener ; private int port = 4554 ; //The constructor which make the TCPListener start listening on the //given port. //It also calls a Thread on the method StartListen(). public DateServer() { try{ //start listing on the given port myListener = new TCPListener(port) ; myListener.Start(); Console.WriteLine("Server Ready - Listining for new Connections ...") ; //start the thread which calls the method 'StartListen' Thread th = new Thread(new ThreadStart(StartListen)); th.Start() ; } catch(Exception e) { Console.WriteLine("An Exception Occured while Listing :"+e.ToString()); } } //main entry point of the class public static void Main(String[] argv) { DateServer dts = new DateServer(); } //This method Accepts new connection and //First it receives the welcome massage from the client, //Then it sends the Current time to the Client. public void StartListen() { while(true) { //Accept a new connection Socket mySocket = myListener.Accept() ; if(mySocket.Connected) { Console.WriteLine("Client Connected!!") ; //make a byte array and receive data from the client Byte[] receive = new Byte[64] ; int i=mySocket.Receive(receive,receive.Length,0) ; char[] unwanted = {' ',' ',' '}; string rece = System.Text.Encoding.ASCII.GetString(receive); Console.WriteLine(rece.TrimEnd(unwanted)) ; //get the current date/time and convert it to string DateTime now = DateTime.Now; String strDateLine ="Server: The Date/Time Now is: "+ now.ToShortDateString() + " " + now.ToShortTimeString(); // Convert to byte array and send Byte[] byteDateLine=Text.Encoding.ASCII.GetBytes(strDateLine.ToCharArray()); mySocket.Send(byteDateLine,byteDateLine.Length,0); } } } } }

2) DateClient.cs:- The Date Time Client

namespace SaurabhNet { using System ; using System.Net.Sockets ; using System.Net ; using System.Threading ; //Class which shows the implementation of the TCP Date Client public class DateClient { //the needed member fields private TCPClient tcpc; private string name ; private int port=4554 ; private bool readData=false ; //Constructor which contains all the code for the client. //It connects to the server and sends the clients name, //Then it waits and receives the date from the server public DateClient(string name) { //a label tryagain : this.name=name ; try { //connect to the "localhost" at the give port //if you have some other server name then you can use that //instead of "localhost" tcpc =new TCPClient("localhost",port) ; //get a Network stream from the server NetworkStream nts = tcpc.GetStream() ; //if the stream is writiable then write to the server if(nts.CanWrite) { string sender = "Hi Server I am "+name ; Byte[] sends = System.Text.Encoding.ASCII.GetBytes(sender.ToCharArray()); nts.Write(sends,0,sends.Length) ; //flush to stream nts.Flush() ; } //make a loop to wait until some data is read from the stream while(!readData&&nts.CanRead) { //if data available then read from the stream if(nts.DataAvailable) { byte[] rcd = new byte[128]; int i=nts.Read( rcd,0,128); string ree = System.Text.Encoding.ASCII.GetString(rcd); char[] unwanted = {' ',' ',' '}; Console.WriteLine(ree.TrimEnd(unwanted)) ; //Exit the loop readData=true ; } } } catch(Exception e) { Console.WriteLine("Could not Connect to server because "+e.ToString()); //Here an exception can be cause if the client is started before starting //the server. //A good way to handle such exceptions and give the client //a chance to re-try to connect to the server Console.Write("Do you want to try Again? [y/n]: ") ; char check = Console.ReadLine().ToChar(); if(check=='y'|| check=='Y') goto tryagain ; } } //Main Entry point of the client class public static void Main(string[] argv) { //check to see if the user has entered his name //if not ask him if he wants to enter his name. if(argv.Length<=0) { Console.WriteLine("Usage: DataClient ") ; Console.Write("Would You like to enter your name now [y/n] ?") ; char check = Console.ReadLine().ToChar(); if(check=='y'|| check=='Y') { Console.Write("Please enter you name :") ; string newname=Console.ReadLine(); DateClient dc = new DateClient(newname) ; Console.WriteLine("Disconnected!!") ; Console.ReadLine() ; } } else { DateClient dc = new DateClient(argv[0]) ; Console.WriteLine("Disconnected!!") ; Console.ReadLine() ; } } } }