Programmer's ROM - The Computer Language Library

home *** CD-ROM | disk | FTP | other *** search

/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / pdl / gad.src < prev next >

Wrap

Text File | 1988-05-03 | 1010.5 KB | 24,108 lines

--:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --gks_specification_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- VERSION 85-11-06 08:00 by JB -- -- THIS VERSION IS CALL COMPATIBLE WITH THE ANSI ADA TO GKS BINDING -- generic type COORDINATE_TYPE is digits <> ; package GKS_COORDINATE_SYSTEM is --------------------------------------------------------- -- The following structure declarations define the -- various GKS coordinate system spaces: -- -- LIMITS : Coordinate system boundary values. -- POINT : Definition of point in coordinate system. -- VECTOR : Definition of vector in coordinate system. -- SIZE : Character size in coordinate system. -- RECTANGLE : Rectangle in coordinate system. --------------------------------------------------------- subtype POSITIVE_COORDINATE_TYPE is COORDINATE_TYPE ; subtype MAGNITUDE is COORDINATE_TYPE ; type LIMITS is record MIN : COORDINATE_TYPE ; MAX : COORDINATE_TYPE ; end record ; type POINT is record X : COORDINATE_TYPE ; Y : COORDINATE_TYPE ; end record ; type POINT_ARRAY is array ( integer range <> ) of POINT ; type VECTOR is record X : COORDINATE_TYPE ; Y : COORDINATE_TYPE ; end record ; type SIZE is record X : POSITIVE_COORDINATE_TYPE ; Y : POSITIVE_COORDINATE_TYPE ; end record ; type RECTANGLE_LIMITS is record X : LIMITS ; Y : LIMITS ; end record ; end GKS_COORDINATE_SYSTEM ; with GKS_COORDINATE_SYSTEM ; package GKS_SPECIFICATION is -- ============================================================== -- This package implements the type declarations for the -- version of the Graphical Kernel System (GKS) developed -- by SYSCON Corporation for use with the Graphic Ada Designer. -- The specification is based on: -- -- 1) The Ada Phase I GKS developed by Harris Corp. -- 2) Draft GKS Binding to ANSI Ada -- -- The types and operations declared below, reflect the -- facilities required by the Graphic Ada Designer. Unused -- operations may be commented out to reduce compilation -- overhead. -- ============================================================== -- -- Define required constants -- -- File name of default error file DEFAULT_ERROR_FILE : constant STRING := "GKS_ERROR_FILE.LIS" ; -- Define the maximum memory available MAXIMUM_MEMORY_AVAILABLE : constant INTEGER := 32767 ; -- Define the maximum number of workstations in the system MAX_WS_TYPE : constant INTEGER := 2 ; -- currently only envision & tek -- Define the decimal digits of floating point precision PRECISION : constant POSITIVE := 5 ; -- Define the lower and upper boundaries of the WC system MIN_WC : constant := 0.0 ; MAX_WC : constant := 32_767.0 ; -- -- Define required types -- -- This type defines an aspect source flag whose value indicates -- whether individual attributes are to be used, or attributes as -- specified in a bundle table. type ASF is ( BUNDLED, INDIVIDUAL ) ; -- Defines a character expansion factor. Factors are unitless, -- and must be greater than zero. type CHAR_EXPANSION is digits PRECISION ; -- Defines a character spacing factor. The factors are -- unitless. A positive value incicates the amount of -- space between characters in a text string, and a -- negative value indicates the amount of overlap between -- characters in a text string. type CHAR_SPACING is digits PRECISION ; -- Indices in to color tables are of this type. type COLOUR_INDEX is new Integer ; -- Defines the range of possible intensities of a color. type INTENSITY is digits PRECISION range 0.0 .. 1.0 ; -- Defines the representation of a color as a -- combination of intensities in an RGB color system. type COLOUR_REPRESENTATION is record RED : INTENSITY ; GREEN : INTENSITY ; BLUE : INTENSITY ; end record ; -- Defines the type for a connection identifier. The -- string must correspond to an external device or -- file as defined by the GKS implementation subtype CONNECTION_ID is STRING(1..6) ; -- Defines the range of accuracy for Device Coordinate types type DC_TYPE is digits PRECISION ; package DC is new GKS_COORDINATE_SYSTEM( DC_TYPE ) ; -- Logical input devices are referenced as device numbers type DEVICE_NUMBER is new POSITIVE ; -- Defines the type for error file specification. The name -- used must conform to an external file name as defined for -- the host system implementation. subtype ERROR_FILE_TYPE is STRING ; -- Defines the range of error indicator values. type ERROR_INDICATOR is new INTEGER ; -- Defines the status of a locator, stroke, valuator, -- or string operation type INPUT_STATUS is ( OK, NONE ) ; -- Defines the fill area interior styles. type INTERIOR_STYLE is ( HOLLOW, SOLID, PATTERN, HATCH ) ; -- Defines the types of line styles provided by GKS. type LINE_TYPE is new Integer ; -- Defines the type for markers provided by GKS. type MARKER_TYPE is new Integer ; -- Defines the type of the units of memory that may be -- allocated for GKS type MEMORY_UNITS is range 0..MAXIMUM_MEMORY_AVAILABLE ; MAX_MEMORY_UNITS : constant MEMORY_UNITS := 32767 ; -- Defines the range of pick identifiers available -- on an implementation type PICK_ID is new POSITIVE ; -- Defines the status of a pick input operation for -- the request function. type PICK_REQUEST_STATUS is ( OK, NOPICK, NONE ) ; -- The type used for unitless scaling factors type SCALE_FACTOR is digits PRECISION ; -- Indicates whether a segment is detectable or not. type SEGMENT_DETECTABILITY is ( UNDETECTABLE , DETECTABLE ) ; -- Indicates whether a segment is highlighted or not type SEGMENT_HIGHLIGHTING is ( NORMAL , HIGHLIGHTED ) ; -- Defines the range of segment names. type SEGMENT_NAME is new POSITIVE ; -- Defines the priority of a segment type SEGMENT_PRIORITY is digits PRECISION range 0.0..1.0 ; -- Indicates whether a segment is visible or not. type SEGMENT_VISIBILITY is ( VISIBLE , INVISIBLE ) ; -- Defines the name of a GKS function detecting an error. subtype SUBPROGRAM_NAME is STRING ; -- Defines the types of fonts provided by the implementation type TEXT_FONT is new Integer ; -- The direction take by a text string type TEXT_PATH is ( RIGHT , LEFT , UP , DOWN ) ; -- The precision with which text appears type TEXT_PRECISION is ( STRING_PRECISION , CHAR_PRECISION , STROKE_PRECISION ) ; -- This type defines a record describing the text font and -- precision aspect. type TEXT_FONT_PRECISION is record FONT : TEXT_FONT ; PRECISION : TEXT_PRECISION ; end record ; -- A normalization transformation number type TRANSFORMATION_NUMBER is new Natural ; -- Defines the range of accuracy for World Coordinate types type WC_TYPE is digits PRECISION range MIN_WC..MAX_WC ; package WC is new GKS_COORDINATE_SYSTEM( WC_TYPE ) ; -- Defines the range of workstation identifiers type WS_ID is new POSITIVE; -- The state of a workstation type WS_STATE is ( INACTIVE, ACTIVE ) ; -- Range of values corresponding to valid workstation -- types. Constants specifying names for the various -- types of workstations should be provided by an -- implementation in the GKS_CONFIGURATION package type WS_TYPE is range 1..MAX_WS_TYPE ; --*** -- -- The following definitions for GKS are non-standard. -- --*** -- Defines a locator input data record type LOCATOR_DATA_RECORD is record T_B_D : NATURAL ; end record ; -- Defines a pick input data record type PICK_DATA_RECORD is record PICK_STATUS : PICK_REQUEST_STATUS ; PICK_SEGMENT : SEGMENT_NAME ; OBJECT_ID : PICK_ID ; end record ; --{ This portion defines the GKS state list, the workstation state --{ list, and the workstation description table. The table --{ definitions contain only a subset of the table fields defined --{ by GKS. The defined table entries support the version of --{ GKS developed by SYSCON Corporation. -- a list containing all of the aspect source flags, -- with componants indication the specific flag. The -- flags are all initialized as individial. type ASF_LIST is record -- Current line attributes LINE_TYPE : ASF := INDIVIDUAL ; LINE_WIDTH : ASF := INDIVIDUAL ; LINE_COLOUR : ASF := INDIVIDUAL ; -- Current marker attributes MARKER_TYPE : ASF := INDIVIDUAL ; MARKER_SIZE : ASF := INDIVIDUAL ; MARKER_COLOUR : ASF := INDIVIDUAL ; -- Current text attributes TEXT_FONT_PRECISION : ASF := INDIVIDUAL ; CHAR_EXPANSION : ASF := INDIVIDUAL ; CHAR_SPACING : ASF := INDIVIDUAL ; TEXT_COLOUR : ASF := INDIVIDUAL ; -- Current fill area attributes INTERIOR_STYLE : ASF := INDIVIDUAL ; STYLE_INDEX : ASF := INDIVIDUAL ; FILL_AREA_COLOUR : ASF := INDIVIDUAL ; end record; --------------------------------------------------------------------- -- Determine type of generalized drawing primitive (GDP) requested. -- All GDP functions based on a two point definition point list -- to completely describe the location of the entity, the two points -- define a box that is used for a rectangle or show the outer limits -- of the circles location using the first (upper left) point as the -- standard reference. --------------------------------------------------------------------- -- Defines a type for selecting a generalized drawing primitive. type GDP_ID is new Integer ; -- Define identifiers for the circle and rectangle drawing function. GDP_CIRCLE : constant GDP_ID := 1 ; GDP_RECTANGLE : constant GDP_ID := 2 ; -- =================================================== -- escape function implementation support for package -- GKS_NON_STANDARD. -- =================================================== type ESCAPE_IDENTIFIER is ( ALPHA_BACKGROUND , ALPHA_WRITING , GRAPHIC_BACKGROUND , GRAPHICS_VISIBILITY , PRINT_SCREEN, PRINT_WINDOW, MAP_WINDOW_TO_VIEWPORT , SEGMENT_MOVEMENT , SELECT_WINDOW ) ; type ESCAPE_RECORD ( IDENTIFIER : ESCAPE_IDENTIFIER ) is record case IDENTIFIER is when ALPHA_BACKGROUND | ALPHA_WRITING | GRAPHIC_BACKGROUND => COLOUR : COLOUR_INDEX ; when GRAPHICS_VISIBILITY => GRAPHICS_ON : Boolean ; when SEGMENT_MOVEMENT => SEGMENT : SEGMENT_NAME ; POSITION : WC.POINT ; when SELECT_WINDOW | PRINT_WINDOW => WINDOW : Natural ; when PRINT_SCREEN => null ; when MAP_WINDOW_TO_VIEWPORT => VIEW_WINDOW_ID : Natural ; WINDOW_RECTANGLE , VIEW_RECTANGLE : WC.RECTANGLE_LIMITS ; when others => null ; end case ; -- IDENTIFIER end record ; -- ESCAPE_RECORD -- ========================================================= -- GKS exceptions -- STATE_ERRORs GKS_ERROR_1 , -- GKS not in proper state: GKS should be in state GKCL GKS_ERROR_2 , -- GKS not in proper state: GKS should be in state GKOP GKS_ERROR_3 , -- GKS not in proper state: GKS should be in state WSAC GKS_ERROR_4 , -- GKS not in proper state: GKS should be in state SGOP GKS_ERROR_5 , -- GKS not in proper state: GKS should be -- either in the state WSAC or in the state SGOP GKS_ERROR_6 , -- GKS not in proper state: GKS should be -- either in the state WSOP or in the state WSAC GKS_ERROR_7 , -- GKS not in proper state: GKS should be -- in one of the states WSOP, WSAC, or SGOP GKS_ERROR_8 , -- GKS not in proper state: GKS should be -- in one of the states GKOP, WSOP, WSAC, or SGOP -- WS_ERRORs GKS_ERROR_20 , -- Specified workstation identifier is invalid GKS_ERROR_21 , -- Specified connection identifier is invalid GKS_ERROR_22 , -- Specified workstation type is invalid GKS_ERROR_23 , -- Specified workstation type does not exist GKS_ERROR_24 , -- Specified workstation is open GKS_ERROR_25 , -- Specified workstation is not open GKS_ERROR_26 , -- Workstation Independent Segment Storage is not open GKS_ERROR_29 , -- Specified workstation is active GKS_ERROR_30 , -- Specified workstation is not active GKS_ERROR_31 , -- Specified workstation is of category MO GKS_ERROR_32 , -- Specified workstation is not of category MO GKS_ERROR_33 , -- Specified workstation is of category MI GKS_ERROR_37 , -- Specified workstation is not of category OUTIN GKS_ERROR_39 , -- Specified workstation is not category INPUT or OUTIN GKS_ERROR_41 , -- Specified workstation cant't generate specified GDP -- TRANSFORMATION_ERRORs GKS_ERROR_50 , -- Transformation number is invalid GKS_ERROR_51 , -- Rectangle definition is invalid GKS_ERROR_52 , -- Viewport not within NDC unit square GKS_ERROR_53 , -- WS window not within NDC unit Square GKS_ERROR_54 , -- WS viewport not within display space -- OUTPUT_ATTRIBUTE_ERRORs GKS_ERROR_60 , -- Polyline index is invalid GKS_ERROR_66 , -- Polymarker index is invalid GKS_ERROR_70 , -- marker index is invalid GKS_ERROR_72 , -- text index is invalid GKS_ERROR_75 , -- text font index is invalid GKS_ERROR_77 , -- character expansion <= 0 GKS_ERROR_78 , -- character height <= 0 GKS_ERROR_79 , -- length of character up vector is 0 GKS_ERROR_80 , -- fill area index is invalid GKS_ERROR_83 , -- interior style index is invalid GKS_ERROR_85 , -- pattern index is invalid GKS_ERROR_93 , -- color index is invalid -- OUTPUT_PRIMITIVE_ERROR GKS_ERROR_100 , -- number of points is invalid GKS_ERROR_101 , -- invalid code in string GKS_ERROR_102 , -- GDP identifier is invalid GKS_ERROR_103 , -- contents of GDP data record is invalid GKS_ERROR_104 , -- WS can't generate specified GDP GKS_ERROR_105 , -- WS can't generate specified GDP transformation -- SEGMENT_ERROR GKS_ERROR_120 , -- Specified segment is invalid GKS_ERROR_121 , -- Specified segment name already in use GKS_ERROR_122 , -- Specified segment doesn't exist GKS_ERROR_125 , -- Specified segment name already in use GKS_ERROR_126 , -- segment priority is invalid -- INPUT_ERRORs GKS_ERROR_146 , -- contents of input data record are invalid GKS_ERROR_147 , -- Input queue has overflowed GKS_ERROR_150 , -- No input value of the correct class is in event report GKS_ERROR_154 , -- length of string > buffer size -- ESCAPE_ERROR GKS_ERROR_180 , -- specified escape not supported GKS_ERROR_181 , -- specified escape identification is invalid GKS_ERROR_182 , -- escape data record is invalid -- SYSTEM_ERROR GKS_ERROR_300 , -- storage overflow in GKS GKS_ERROR_301 , -- storage overflow in segment storage GKS_ERROR_302 , -- input/output error while reading GKS_ERROR_303 , -- input/output error while writing GKS_ERROR_304 , -- input/output error while sending data to WS GKS_ERROR_305 , -- input/output error while recieving data from WS GKS_ERROR_306 , -- input/output error during library management GKS_ERROR_307 , -- input/output error while reading WS description table GKS_ERROR_308 , -- arithmetic error has occured -- LANGUAGE_BINDING_ERROR GKS_ERROR_2500 , -- invalid use of input data record -- UNKNOWN_OTHER_ERROR GKS_ERROR_2501 -- unknown GKS detected error : EXCEPTION ; end GKS_SPECIFICATION ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --graphics_data_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-01-17 17:40 by JL with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; package GRAPHICS_DATA is -- ================================================================ -- -- This package provides the data types containing the graphic -- information (location and attributes) for each entity in -- the graph. Some of the data is device dependent, and hence -- this declaration is separated from the GRAPH_TREE_ACCESS_PACKAGE. -- The pointer to the owning TREE_NODE is maintained in a record -- which includes the record type declared below. This data -- will be maintained in arrays, which will allow fairly fast -- searchs to be conducted. -- -- ================================================================== ---------------------------------- -- The three windows of SKETCHER ---------------------------------- type WINDOW_TYPE is ( GRAPH_VIEW_PORT, -- The graph viewport window MENU_VIEW_PORT , -- The command window TEXT_VIEW_PORT ) ; -- Text interaction window ------------------------------------------------ -- The angular direction used in whole degrees. ------------------------------------------------ subtype ANGLE_TYPE is NATURAL range 1..360 ; -------------------------------------- -- ID number of a segment of objects. -------------------------------------- NULL_SEGMENT : constant GKS_SPECIFICATION.SEGMENT_NAME := GKS_SPECIFICATION.SEGMENT_NAME'first ; -------------------------------------- -- Define a list of segments. -------------------------------------- type SEGMENT_LIST_TYPE is array( NATURAL range <> ) of GKS_SPECIFICATION.SEGMENT_NAME ; --------------------------------------------------------- -- The following type declarations define the -- graphics World Coordinate System space; these -- type definitions differ from the GKS World Coordinate -- types. -- -- WC : Definition for World Coordinate (WC) system variables. -- LIMITS : World coordinate system boundary values. -- POINT : Definition of point in world coordinate system. -- VECTOR : Definition of vector in world coordinate system. -- SIZE : Character size in world coordinate system. -- RECTANGLE: Rectangle in world coordinate system. --------------------------------------------------------- MAX_WC : constant NATURAL := 32_767 ; MIN_WC : constant NATURAL := 0 ; subtype WC is NATURAL range MIN_WC..MAX_WC ; type LIMITS is record MIN : WC ; MAX : WC ; end record ; type POINT is record X : WC ; Y : WC ; end record ; type POINT_LIST is array ( integer range <> ) of POINT ; type VECTOR is record X : WC ; Y : WC ; end record ; type SIZE is record X : WC ; Y : WC ; end record ; type RECTANGLE is record X : LIMITS ; Y : LIMITS ; end record ; -------------------------------------- -- Define a null point ------------------------------------- NULL_POINT : constant POINT := ( X => 0 , Y => 0 ) ; ------------------------------------------------------- -- The priority of viewing scale. ------------------------------------------------------- subtype PRIORITY_TYPE is FLOAT range 0.0..1.0 ; ------------------------------------------------------- -- The scale factor to be utilized for software zoom. ------------------------------------------------------- subtype SCALE_FACTOR_TYPE is NATURAL range 1..8 ; ------------------------------------------------------- -- Define the zoom direction. ------------------------------------------------------- type ZOOM_DIRECTION is ( MAX_ZOOM_IN , ZOOM_IN , MAX_ZOOM_OUT , ZOOM_OUT ) ; ------------------------------------------------------- -- Define the pan direction. ------------------------------------------------------- type PAN_DIRECTION is ( MAX_PAN_LEFT , PAN_LEFT , MAX_PAN_RIGHT , PAN_RIGHT , MAX_PAN_UP , PAN_UP , PAN_DOWN , MAX_PAN_DOWN ) ; ------------------------------------------------------- -- The line type to be utilized in drawing lines. ------------------------------------------------------- type LINE_TYPE is ( SOLID, DASHED, DOTTED ) ; ------------------------------------------------------- -- End of line terminators for use in drawing connectors. ------------------------------------------------------- type TERMINATOR_TYPE is ( NONE, LEFT_ARROW, RIGHT_ARROW, PLUS_SIGN ) ; ------------------------------------------------------------------ -- Define the available colors. ------------------------------------------------------------------ type COLOR_TYPE is ( ORANGE, GREEN, YELLOW, VIOLET, RED, BLUE, BLACK, WHITE, BROWN, DARK_RED, CYAN, PINK, MAGENTA, PEACH, GRAY, DARK_PURPLE ) ; ---------------------------- -- Graphics data declaration ---------------------------- type GRAPHICS_DATA_TYPE is record WINDOW : WINDOW_TYPE := GRAPH_VIEW_PORT ; LABEL_SEG_ID : GKS_SPECIFICATION.SEGMENT_NAME := NULL_SEGMENT ; LABEL2_SEG_ID : GKS_SPECIFICATION.SEGMENT_NAME := NULL_SEGMENT ; SEGMENT_ID : GKS_SPECIFICATION.SEGMENT_NAME := NULL_SEGMENT ; LOCATION : POINT := NULL_POINT ; SIZE : POINT := NULL_POINT ; COLOR : COLOR_TYPE := BLACK ; end record ; ------------------------ -- GENERIC informations ------------------------ type GENERIC_STATUS_TYPE is ( NON_GENERIC, GENERIC_DECLARATION, GENERIC_INSTANTIATION ) ; --------------------------------------- -- The possible Call Connection types. --------------------------------------- type CALL_CONNECTION_TYPE is ( NO_CONNECTION, NORMAL, TIMED, CONDITIONAL ) ; --------------------------------------- -- The possible label types, request point -- scope checking of labels, an entry point -- is considered as a LABEL_EXPORT --------------------------------------- type LABEL_CREATE_TYPE is ( NOT_LABEL, LABEL_IMPORT, LABEL_EXPORT ) ; ------------------------------------------- -- General signal parameter for operations. ------------------------------------------- type MODE_TYPE is ( ON , OFF ) ; ---------------------------------------------------- -- The Maximum nesting level for enclosing objects. ---------------------------------------------------- MAX_NESTING_LEVEL : constant INTEGER := 6 ; type IMPORT_EXPORT_SYMBOL_TYPE is array (1..2) of STRING (1..1) ; PKG_DECL : IMPORT_EXPORT_SYMBOL_TYPE := ("#","#") ; VIRT_PKG_DECL : IMPORT_EXPORT_SYMBOL_TYPE := ("%","%") ; TYPE_DECL : IMPORT_EXPORT_SYMBOL_TYPE := ("(",")") ; OBJECT_DECL : IMPORT_EXPORT_SYMBOL_TYPE := (":",":") ; EXCEPTION_DECL : IMPORT_EXPORT_SYMBOL_TYPE := ("<",">") ; SUBPROG_DECL : IMPORT_EXPORT_SYMBOL_TYPE := ("|","|") ; PARAMS_DECL : IMPORT_EXPORT_SYMBOL_TYPE := ("[","]") ; TASK_ENTRY_DECL : IMPORT_EXPORT_SYMBOL_TYPE := ("/","/") ; SERIAL_ENTRY_DECL : IMPORT_EXPORT_SYMBOL_TYPE := ("/","}") ; ENTRY_FAMILY_DECL : IMPORT_EXPORT_SYMBOL_TYPE := ("(",")") ; subtype INDICATOR_LENGTH_1 is STRING ( 1..1 ) ; subtype INDICATOR_LENGTH_2 is STRING ( 1..2 ) ; subtype INDICATOR_LENGTH_4 is STRING ( 1..4 ) ; FUNCTION_SYMBOL : INDICATOR_LENGTH_1 := "=" ; NORMAL_REFERENCE_SYMBOL : INDICATOR_LENGTH_1 := ">" ; VIRTUAL_REFERENCE_SYMBOL : INDICATOR_LENGTH_2 := ">>" ; TIMED_CALL_SYMBOL : INDICATOR_LENGTH_1 := "T" ; CONDITIONAL_CALL_SYMBOL : INDICATOR_LENGTH_1 := "C" ; GUARDED_ENTRY_SYMBOL : INDICATOR_LENGTH_1 := "*" ; GENERIC_DECL_SYMBOL : INDICATOR_LENGTH_2 := "gd" ; GENERIC_INST_SYMBOL : INDICATOR_LENGTH_2 := "gi" ; DATA_ORIGIN_SYMBOL : INDICATOR_LENGTH_1 := "V" ; TASK_TYPE_SYMBOL : INDICATOR_LENGTH_4 := "(tt)" ; ------------------------------------------------------------ -- This structure defines the shape to be drawn for -- each of the entities which can be graphed. ------------------------------------------------------------ type SHAPE_TYPE is ( SINGLE_RECTANGLE, STACKED_RECTANGLE, SQUARE, PARALLELOGRAM, CIRCLE ) ; ------------------------------------------------------------ -- Define the supported graphic entities. ------------------------------------------------------------ type GRAPHIC_ENTITY is ( VIRTUAL_PKG_FIGURE, PACKAGE_FIGURE, SUBPROGRAM_FIGURE, TASK_FIGURE, BODY_FIGURE, CALL_CONNECT_LINE, DATA_CONNECT_LINE, EXPORT_CONNECT_LINE ) ; ------------------------------------------------------------ -- Define the supported graphic entities which consist of -- a line, and those which consist a figure. ------------------------------------------------------------ subtype LINE_ENTITY is GRAPHIC_ENTITY range CALL_CONNECT_LINE..EXPORT_CONNECT_LINE ; subtype FIGURE_ENTITY is GRAPHIC_ENTITY range VIRTUAL_PKG_FIGURE..BODY_FIGURE ; ------------------------------------------------------------ -- Define the arrays containing the current attributes for -- each of the supported graphic entities. ------------------------------------------------------------ type SHAPE_ARRAY is array ( FIGURE_ENTITY ) of SHAPE_TYPE ; type LINE_ARRAY is array ( GRAPHIC_ENTITY ) of LINE_TYPE ; type COLOR_ARRAY is array ( GRAPHIC_ENTITY ) of COLOR_TYPE ; ------------------------------------------------------------------- -- Initialize the arrays containing the current attributes for -- each of the supported graphic entities. ------------------------------------------------------------------- ENTITY_SHAPE : SHAPE_ARRAY := ( VIRTUAL_PKG_FIGURE => SHAPE_TYPE'( SINGLE_RECTANGLE ), PACKAGE_FIGURE => SHAPE_TYPE'( SINGLE_RECTANGLE ), SUBPROGRAM_FIGURE => SHAPE_TYPE'( STACKED_RECTANGLE ), TASK_FIGURE => SHAPE_TYPE'( PARALLELOGRAM ), BODY_FIGURE => SHAPE_TYPE'( CIRCLE ) ); ENTITY_LINE : LINE_ARRAY := ( VIRTUAL_PKG_FIGURE => LINE_TYPE'( DASHED ), PACKAGE_FIGURE => LINE_TYPE'( SOLID ), SUBPROGRAM_FIGURE => LINE_TYPE'( SOLID ), TASK_FIGURE => LINE_TYPE'( SOLID ), BODY_FIGURE => LINE_TYPE'( SOLID ), CALL_CONNECT_LINE => LINE_TYPE'( SOLID ), DATA_CONNECT_LINE => LINE_TYPE'( DOTTED ) , EXPORT_CONNECT_LINE => LINE_TYPE'( DOTTED ) ); ENTITY_COLOR : COLOR_ARRAY := ( VIRTUAL_PKG_FIGURE => COLOR_TYPE'( BLACK ), PACKAGE_FIGURE => COLOR_TYPE'( BLACK ), SUBPROGRAM_FIGURE => COLOR_TYPE'( BLACK ), TASK_FIGURE => COLOR_TYPE'( BLACK ), BODY_FIGURE => COLOR_TYPE'( BLACK ), CALL_CONNECT_LINE => COLOR_TYPE'( BLACK ), DATA_CONNECT_LINE => COLOR_TYPE'( BLACK ) , EXPORT_CONNECT_LINE => COLOR_TYPE'( BLACK ) ); ------------------------------------------------- -- ICON Structure Definition ------------------------------------------------- subtype ICON_TYPE is POSITIVE range 1 .. 100 ; ------------------------------------------------- -- offset constants for labels ------------------------------------------------- DEFAULT_CHARACTER_HEIGHT : constant WC := 200 ; DEFAULT_CHARACTER_WIDTH : constant WC := 150 ; DEFAULT_CHARACTER_HEIGHT_SPACING : constant WC := 100 ; DEFAULT_CHARACTER_WIDTH_SPACING : constant WC := 75 ; CHARACTER_HEIGHT_OFFSET : constant WC := DEFAULT_CHARACTER_HEIGHT + DEFAULT_CHARACTER_HEIGHT_SPACING ; CHARACTER_WIDTH_OFFSET : constant WC := DEFAULT_CHARACTER_WIDTH + DEFAULT_CHARACTER_WIDTH_SPACING ; ENTITY_NAME_Y_OFFSET : constant WC := CHARACTER_HEIGHT_OFFSET ; IMPORT_EXPORT_X_OFFSET : constant WC := ( 2 * CHARACTER_WIDTH_OFFSET ) - ( DEFAULT_CHARACTER_WIDTH_SPACING / 2 ) ; -- label_max_length does not include the identifying symbols LABEL_MAX_LENGTH : constant WC := 8 * CHARACTER_WIDTH_OFFSET ; STACKED_SIZE : constant WC := DEFAULT_CHARACTER_HEIGHT + ( 2 * DEFAULT_CHARACTER_HEIGHT_SPACING ) ; ------------------------------------------------- -- Exception raised when operator requests the -- abort of an operation in the graphics window. ------------------------------------------------- OPERATION_ABORTED_BY_OPERATOR : exception ; ------------------------------------------------- -- Exception raised when the list of available -- segments is exhausted. ------------------------------------------------- AVAILABLE_SEGMENTS_EXHAUSTED : exception ; end GRAPHICS_DATA ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --tekdriver_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: package TEKDRIVER is -- -- This package implements a device driver for the Tektronix -- 4107 display terminal. -- The procedure names are derived from the descriptive command -- names specified in the "TEK Programmers Reference - -- 4107/4109 Computer Display Terminal." -- -- The only graphics input device supported is the joydisk. -- -- Define control characters as strings of length one. -- The strings are initialized in the package body. ESC : STRING(1..1); FF : STRING(1..1); FS : STRING(1..1); GS : STRING(1..1); US : STRING(1..1); CN : STRING(1..1); -- Define the signature characters to be used in the locator -- and pick reports. LOCATOR_SIG_CHAR : constant CHARACTER := '['; LOCATOR_TRM_CHAR : constant CHARACTER := ']'; PICK_SIG_CHAR : constant CHARACTER := '{'; PICK_TRM_CHAR : constant CHARACTER := '}'; -- The range of valid values for segment identifiers. -- -1 specifies all segments ( except segment 0 ). -- 0 specifies the segment containing the cursor. -- 1..32767 identifies a specific segment subtype SEGMENT_IDENTIFIER is INTEGER range -1..32767; -- The range of valid values for view identifiers. subtype VIEW_NUMBER is INTEGER range -1..64; -- The range of valid values for the color index. -- Values greater than 15 are interpreted as color index 15 subtype COLOR_INDEX is NATURAL range 0..32767; FIRST_COLOR : constant COLOR_INDEX := 0 ; LAST_COLOR : constant COLOR_INDEX := 15 ; DIALOG_LAST_COLOR : constant COLOR_INDEX := 7 ; -- The range of valid values for a color coordinate in the -- RGB color coordinate model. subtype COLOR_COORDINATE is NATURAL range 0..100; -- The range of valid values for line style. subtype LINE_STYLE is NATURAL range 0..7; -- The range of valid values for the marker number. subtype MARKER_NUMBER is NATURAL range 0..10; -- The range of valid surface number identifiers, and surface -- priority identifiers subtype SURFACE_NUMBER is NATURAL range 1..4; subtype SURFACE_PRIORITY is NATURAL range 1..4; SURFACE_1 : constant SURFACE_NUMBER := 1 ; SURFACE_2 : constant SURFACE_NUMBER := 2 ; SURFACE_3 : constant SURFACE_NUMBER := 3 ; SURFACE_4 : constant SURFACE_NUMBER := 4 ; PRIORITY_1 : constant SURFACE_PRIORITY := 1 ; PRIORITY_2 : constant SURFACE_PRIORITY := 2 ; PRIORITY_3 : constant SURFACE_PRIORITY := 3 ; PRIORITY_4 : constant SURFACE_PRIORITY := 4 ; -- The range of valid bit plane numbers; -- if number of planes is 0 the surface is not used. subtype BIT_PLANES is NATURAL range 0..4; -- The range of the size of the input queue in bytes subtype INPUT_QUEUE_SIZE is POSITIVE range 1..65535 ; -- The range of valid pick identification numbers. subtype PICK_ID_IDENTIFIER is NATURAL range 0..32767; -- The range of valid segment priority numbers. subtype PRIORITY_NUMBER is INTEGER range -32766..32767; -- Number of points whose position will be reported in a -- GIN report sequence. subtype NUMBER_OF_GIN_EVENTS is POSITIVE range 1..32767; -- Define string type for xy coordinates strings. subtype XY_COORDINATES_STRING is STRING(1..5); -- Define string type for integer strings. subtype TEK_INTEGER_STRING is STRING(1..3); -- The range of valid values for terminal X- and Y- coordinates. TERMINAL_COORDINATE_MIN : constant NATURAL := 0 ; TERMINAL_COORDINATE_MAX : constant NATURAL := 4095 ; subtype TERMINAL_COORDINATE is NATURAL range TERMINAL_COORDINATE_MIN..TERMINAL_COORDINATE_MAX ; -- The range of valid values for screen X- coordinates. SCREEN_X_COORDINATE_MIN : constant NATURAL := 0 ; SCREEN_X_COORDINATE_MAX : constant NATURAL := 4095 ; subtype SCREEN_X_COORDINATE is NATURAL range SCREEN_X_COORDINATE_MIN..SCREEN_X_COORDINATE_MAX ; -- The range of valid values for screen Y- coordinates. SCREEN_Y_COORDINATE_MIN : constant NATURAL := 0 ; SCREEN_Y_COORDINATE_MAX : constant NATURAL := 3071 ; subtype SCREEN_Y_COORDINATE is NATURAL range SCREEN_Y_COORDINATE_MIN..SCREEN_Y_COORDINATE_MAX ; type TERMINAL_POINT is record X : TERMINAL_COORDINATE ; Y : TERMINAL_COORDINATE ; end record; type SCREEN_POINT is record X : SCREEN_X_COORDINATE ; Y : SCREEN_Y_COORDINATE ; end record; -- Specifies whether the fill pattern covers the panel boundary, -- or whether the boundary is drawing using the current line style. type BOUNDARY is ( FILL_PATTERN, CURRENT_LINE_STYLE ) ; -- Specify the levels of error messages displayed by the terminal. type ERROR_DISPLAY_LEVEL is ( DISPLAY_ALL, DISPLAY_WARNINGS, DISPLAY_ERRORS, DISPLAY_FAILURES, NOTHING_DISPLAYED ) ; -- Specifies number of lines of text in visible in the dialog area. subtype DIALOG_LINES is INTEGER range 2..32; -- Specifies if dialog area should be enabled or disabled. type DIALOG_MODE is ( DISABLE_DIALOG, ENABLE_DIALOG ) ; -- Specifies how many pages to copy when a hardcopy is requested subtype NUMBER_OF_PAGES is INTEGER range 0..32767 ; -- Specifies hardcopy starting point type PAGE_ORIGIN is ( FIRST_LINE, TOP_OF_BUFFER, BOTTOM_OF_BUFFER ) ; -- Specifies how form feed is interpreted during hardcopy operation type FORM_FEED_INTERPRETATION is ( IGNORE_FF, MAX_LINES, NEW_PAGE ) ; -- Select the image size for a hardcopy operation type IMAGE_SIZE is ( DEFAULT_SIZE, SMALLER_SIZE ) ; -- Specifies dialog area, segment, and view border visibility. type VISIBILITY_MODE is ( INVISIBLE, VISIBLE ) ; -- Specifies surface visibility. type SURFACE_VISIBILITY is ( SURFACE_INVISIBLE, SURFACE_VISIBLE, SURFACE_BLINKING ) ; -- Lock or unlock the zoom and pan modes. type LOCKING_MODE is ( UNLOCK_KEYS, LOCK_KEYS ) ; -- Define the valid range for macro identifiers. subtype MACRO_NUMBER is INTEGER range -150..32767 ; -- Determine how often the terminal sends an EOL string to the host type EOM_FREQUENCY is ( LESS_FREQUENT, MORE_FREQUENT ) ; -- Specify whether or not the segment can be picked. type DETECTABILITY is ( CANNOT_BE_PICKED, CAN_BE_PICKED ) ; -- Specify whether key macro expansion is enabled or disabled type KEY_EXPANSION is ( DISABLED, ENABLED ) ; -- Specify whether or not segment is highlighted. type HIGHLIGHTING is ( NOT_HIGHLIGHTED, HIGHLIGHTED ) ; -- Specifies whether or not the terminal is in snoopy mode. type SNOOPY_MODE is ( IN_SNOOPY_MODE, NOT_IN_SNOOPY_MODE ) ; -- Specifies devices supported by this implementation. type DEVICE_CODE is ( JOYDISK ) ; -- Specifies functions supported by this implementation. type FUNCTION_CODE is ( LOCATOR, PICK ) ; -- Specifies how hard copy is to be produced. -- COPY_SCREEN_X - copies the entire screen -- POSITIVE_HARDCOPY - produces positive copy of entire screen -- DIALOG_AREA_COPY - copies only the dialog area type HARDCOPY_CODE is ( COPY_SCREEN_0, COPY_SCREEN_1, POSITIVE_HARDCOPY, DIALOG_AREA_COPY ) ; -- Specifies the copier type. type COPIER_TYPE is ( MONOCHROME_PRINTER, TEK_4695 ) ; -- Specifies the terminal mode. type TERMINAL_MODE is ( TEK, ANSI, EDIT, VT52 ) ; -- Specify the fill pattern for subsequent panels. The values -15 -- through 0 fill a panel with a solid color indicated by the negative -- value of a color index ( i.e. -3 means fill with color index 3 ). subtype FILL_PATTERN_NUMBER is INTEGER range -15..16; -- Specifies graphtext character path. type CHARACTER_DIRECTION is ( RIGHT, LEFT, UP, DOWN ) ; -- Specifies the color coordinate system used. type COLOR_COORDINATE_SYSTEM is ( NO_COORDINATE_CHANGE, RGB, CMY, HLS ) ; -- Specifies the mode used when colors are place on top of each other. type COLOR_OVERLAY_TYPE is ( NO_OVERLAY_CHANGE, OPAQUE, SUBTRACTIVE, ADDITIVE ) ; -- Specifies a record containing the definition of a color index -- in terms of relative percentages. type COLOR_RECORD is record RED : COLOR_INDEX ; GREEN : COLOR_INDEX ; BLUE : COLOR_INDEX ; end record ; INITIAL_COLORS : array ( FIRST_COLOR..LAST_COLOR ) of COLOR_RECORD := ( 0 => ( RED => 100, GREEN => 100, BLUE => 100) , -- white 1 => ( RED => 100, GREEN => 0, BLUE => 0) , -- red 2 => ( RED => 0, GREEN => 100, BLUE => 0) , -- green 3 => ( RED => 0, GREEN => 0, BLUE => 100) , -- blue 4 => ( RED => 100, GREEN => 60, BLUE => 0) , -- orange 5 => ( RED => 100, GREEN => 100, BLUE => 0) , -- yellow 6 => ( RED => 74, GREEN => 60, BLUE => 87) , -- violet 7 => ( RED => 0, GREEN => 0, BLUE => 0) , -- black 8 => ( RED => 47, GREEN => 7, BLUE => 47) , -- dark_purple 9 => ( RED => 67, GREEN => 34, BLUE => 0) , -- brown 10 => ( RED => 80, GREEN => 0, BLUE => 0) , -- dark_red 11 => ( RED => 0, GREEN => 100, BLUE => 100) , -- cyan 12 => ( RED => 100, GREEN => 27, BLUE => 74) , -- pink 13 => ( RED => 100, GREEN => 0, BLUE => 100) , -- magenta 14 => ( RED => 94, GREEN => 40, BLUE => 60) , -- peach 15 => ( RED => 67, GREEN => 67, BLUE => 67) ) ; -- gray -- Specify labels for the initial system colors WHITE : constant COLOR_INDEX := 0 ; RED : constant COLOR_INDEX := 1 ; GREEN : constant COLOR_INDEX := 2 ; BLUE : constant COLOR_INDEX := 3 ; ORANGE : constant COLOR_INDEX := 4 ; YELLOW : constant COLOR_INDEX := 5 ; VIOLET : constant COLOR_INDEX := 6 ; BLACK : constant COLOR_INDEX := 7 ; DARK_PURPLE : constant COLOR_INDEX := 8 ; BROWN : constant COLOR_INDEX := 9 ; DARK_RED : constant COLOR_INDEX := 10 ; CYAN : constant COLOR_INDEX := 11 ; PINK : constant COLOR_INDEX := 12 ; MAGENTA : constant COLOR_INDEX := 13 ; PEACH : constant COLOR_INDEX := 14 ; GRAY : constant COLOR_INDEX := 15 ; -- Specifies whether operation is color or black and white. type COLOR_OPERATION_MODE is ( NO_OPERATION_CHANGE, NORMAL_COLOR_OPERATION ) ; -- Specify rubberbanding modes. -- DISABLE - disable rubberbanding -- ENABLE_1 - cause rubberbanding between most recent locator event -- and the current cursor position -- ENABLE_2 - cause initial rubberbanding between GIN display start -- point and current cursor position, subsequent same as 1 type RUBBERBANDING_MODE is ( DISABLE, ENABLE_1, ENABLE_2 ) ; -- Specify string or stroke precision on graphtext characters. type GRAPHTEXT_PRECISION is ( FILLER, STRING_TEXT, STROKE_TEXT ) ; procedure BEGIN_PANEL_BOUNDARY ( FIRST_POINT : in TERMINAL_POINT ; DRAW_BOUNDARY : in BOUNDARY ) ; -- Start a panel definition. procedure BEGIN_SEGMENT ( SEGMENT_ID : in SEGMENT_IDENTIFIER ) ; -- Begin a new segment, and reset the current pick id to 1. procedure CANCEL ; -- Cancel terminal operations and several terminal -- parameters and modes. procedure CLEAR_DIALOG_SCROLL ; -- Erase the dialog buffer. procedure DEFINE_MACRO( MACRO : in MACRO_NUMBER ; TEXT : in STRING ) ; -- Create or delete volatile macros procedure DEFINE_MACRO( MACRO : in MACRO_NUMBER ) ; -- Delete volatile macros procedure DELETE_SEGMENT ( SEGMENT_ID : in SEGMENT_IDENTIFIER ) ; -- Remove a segment from memory. procedure DELETE_VIEW ( VIEW_ID : in VIEW_NUMBER ) ; -- Delete the specified view. procedure DISABLE_GIN ; -- Disable all GIN devices. procedure DRAW ( POSITION : in TERMINAL_POINT ) ; -- Draw a vector from the current graphics position to the -- specified location. procedure DRAW_MARKER ( POSITION : in TERMINAL_POINT ) ; -- Draw a marker at the specified location. procedure ENABLE_DIALOG_AREA ( ENABLE_AREA : in DIALOG_MODE ) ; -- Enable or disable the dialog area. procedure ENABLE_GIN ( DEVICE : in DEVICE_CODE ; GIN_FUNCTION : in FUNCTION_CODE ; NUMBER_OF_EVENTS : in NUMBER_OF_GIN_EVENTS ) ; -- Enable the terminal for graphics procedure ENABLE_KEY_EXPANSION( EXPANSION : in KEY_EXPANSION ) ; -- Enables or disables key macros procedure END_PANEL ; -- Terminate a panel definition. procedure END_SEGMENT ; -- Terminate the segment currently being defined. procedure ENTER_ALPHA_MODE ; -- Place the terminal in alpha mode. procedure ENTER_BYPASS_MODE ; -- Place the terminal in bypass mode. procedure ENTER_MARKER_MODE ; -- Place the terminal in marker mode. procedure ENTER_VECTOR_MODE ; -- Place the terminal in vector mode. procedure GRAPHIC_TEXT ( TEXT : in STRING ) ; -- Write a string of graphtext starting at the current -- graphics position. procedure HARDCOPY ( COPY_CODE : in HARDCOPY_CODE ) ; -- Causes an attached hardcopy unit to make a copy of the terminal's -- screen or dialog area. procedure INCLUDE_COPY_OF_SEGMENT ( SEGMENT_ID : in SEGMENT_IDENTIFIER ) ; -- Copies another segment into the segment currently being -- defined procedure LOCK_VIEWING_KEYS ( LOCK_KEYS : in LOCKING_MODE ) ; -- Locks and unlocks the zoom and pan modes. procedure MOVE ( POSITION : in TERMINAL_POINT ) ; -- Set the current graphics position without drawing a vector. procedure PAGE ; -- Erase the screen except the dialog area. procedure RENAME_SEGMENT ( OLD_SEGMENT : in SEGMENT_IDENTIFIER ; NEW_SEGMENT : in SEGMENT_IDENTIFIER ) ; -- Rename an existing segment. procedure RENEW_VIEW ( VIEW : in VIEW_NUMBER ) ; -- Erase the specified view and redraw all segments visible -- in that view. procedure REPORT_ERRORS ; -- Cause the terminal to send an error report to the host. procedure RESET ; -- Returns the terminal to its power_up condition. procedure SELECT_CODE ( MODE : in TERMINAL_MODE ) ; -- Cause the terminal to recognize Ansi, Tek, or VT52 mode -- command syntax. procedure SELECT_FILL_PATTERN ( FILL_PATTERN : in FILL_PATTERN_NUMBER ) ; -- Specifies the fill pattern for subsequent panels. procedure SELECT_HARDCOPY_INTERFACE ( COPIER : in COPIER_TYPE ) ; -- Select the copies type to be used in the HARDCOPY command. procedure SELECT_VIEW ( VIEW : in VIEW_NUMBER ) ; -- Specifies which view is the current view. procedure SET_ALPHA_CURSOR_INDICES ( FIRST_COLOR : in COLOR_INDEX ; SECOND_COLOR : in COLOR_INDEX ) ; -- Assigns specified color indices to the alpha cursor. procedure SET_BACKGROUND_COLOR ( FIRST_COLOR : in COLOR_INDEX ; SECOND_COLOR : in COLOR_INDEX ; THIRD_COLOR : in COLOR_INDEX ) ; -- Sets the color of the background surface which is behind all -- of the transparent writing surfaces. procedure SET_BORDER_VISIBILITY ( BORDER_VISIBLE : in VISIBILITY_MODE ) ; -- Controls the visibility of a border drawn around the current -- view's viewport. procedure SET_CHARACTER_PATH ( PATH : in CHARACTER_DIRECTION ) ; -- Specifies the direction to move after writing each -- graphtext character. procedure SET_COLOR_MODE ( COLOR_SYSTEM : in COLOR_COORDINATE_SYSTEM ; COLOR_OVERLAY : in COLOR_OVERLAY_TYPE ; COLOR_OR_GRAY : in COLOR_OPERATION_MODE ) ; -- Set the color mode for the terminal. procedure SET_COPY_SIZE ( IMAGE : in IMAGE_SIZE ) ; -- Selects the copy size to produce a standard or reduced image. procedure SET_DIALOG_AREA_BUFFER_SIZE ( LINES : in DIALOG_LINES ) ; -- Specify the maximum number of lines of text stored in the -- dialog area buffer. procedure SET_DIALOG_AREA_COLOR_MAP ( COLOR_TO_UPDATE : in COLOR_INDEX ; RED_PERCENTAGE : in COLOR_COORDINATE ; GREEN_PERCENTAGE : in COLOR_COORDINATE ; BLUE_PERCENTAGE : in COLOR_COORDINATE ) ; -- Specify the color assigned to a color index in the dialog area. procedure SET_DIALOG_AREA_HARDCOPY_ATTRIBUTES ( PAGES : in NUMBER_OF_PAGES ; ORIGIN : in PAGE_ORIGIN ; FF_INTERPRET : in FORM_FEED_INTERPRETATION ) ; -- Specifies the number of pages to be copied, the starting -- page, and how the form feed is interpreted. procedure SET_DIALOG_AREA_INDEX ( CHAR_INDEX : in COLOR_INDEX ; CHAR_BACKGROUND_INDEX : in COLOR_INDEX ; DIALOG_BACKGROUND_INDEX : in COLOR_INDEX ) ; -- Specify the color index for alphatext characters, character-cell -- background, and dialog area background. procedure SET_DIALOG_AREA_LINES ( LINES : in DIALOG_LINES ) ; -- Specify the maximum number of lines visible in the dialog area. procedure SET_DIALOG_AREA_VISIBILITY ( AREA_VISIBLE : in VISIBILITY_MODE ) ; -- Specifies whether the dialog area is visible or invisible. procedure SET_EOM_CHARACTERS ( FIRST_EOM : in CHARACTER ; SECOND_EOM : in CHARACTER ); -- Specifies the characters used to terminate messages. procedure SET_ERROR_THRESHOLD ( ERROR_DISPLAY : in ERROR_DISPLAY_LEVEL ) ; -- Specifies the levels of error messages the terminal displays procedure SET_GIN_CURSOR_COLOR ( RED_PERCENTAGE : in COLOR_COORDINATE ; GREEN_PERCENTAGE : in COLOR_COORDINATE ; BLUE_PERCENTAGE : in COLOR_COORDINATE ) ; -- Specifies the color mixture for the graphics crosshair cursor. procedure SET_GIN_DISPLAY_START_POINT ( DEVICE : in DEVICE_CODE ; GIN_FUNCTION : in FUNCTION_CODE ; START_POINT : in TERMINAL_POINT ) ; -- Specifies an initial point for GIN inking or GIN rubberbanding. procedure SET_GIN_RUBBERBANDING ( DEVICE : in DEVICE_CODE ; GIN_FUNCTION : in FUNCTION_CODE ; RUBBERBANDING : in RUBBERBANDING_MODE ) ; -- Turns rubberbanding on or off for all subsequent operations of -- the specified Locator function. procedure SET_GRAPHTEXT_PRECISION ( PRECISION : in GRAPHTEXT_PRECISION ) ; -- Selects string-precision or stroke-precision to draw graphtext -- characters. procedure SET_GRAPHTEXT_SIZE ( WIDTH : in TERMINAL_COORDINATE ; HEIGHT : in TERMINAL_COORDINATE ; SPACING : in TERMINAL_COORDINATE ) ; -- Set the size of graphics text. procedure SET_LINE_INDEX ( LINE_INDEX : in COLOR_INDEX ) ; -- Specify the color index for all subsequent lines, -- panel boundaries, and markers. procedure SET_LINE_STYLE ( LINE : in LINE_STYLE ) ; -- Specify the line style for subsequent lines and panel boundaries. procedure SET_MARKER_TYPE ( MARKER : in MARKER_NUMBER ) ; -- Specify the marker style. procedure SET_PICK_APERTURE ( APERTURE_WIDTH : in TERMINAL_COORDINATE ) ; -- Sets the size of the GIN cursor aperture used to pick segments. procedure SET_PICK_ID ( PICK_ID : in PICK_ID_IDENTIFIER ) ; -- Mark the next xy location added to the currently open segment -- as a pick point and assign the specified identification number. procedure SET_PIVOT_POINT ( PIVOT_POINT : in TERMINAL_POINT ) ; -- Specify the pivot point for subsequent segment definitions. procedure SET_QUEUE_SIZE ( QUEUE_SIZE : in INPUT_QUEUE_SIZE ) ; -- Specifies the size in bytes of the terminal's input queue -- for RS-232 communications. procedure SET_REPORT_EOM_FREQUENCY ( FREQUENCY : in EOM_FREQUENCY ) ; -- Specifies how often the terminal sends an EOL string to -- the host. procedure SET_REPORT_SIG_CHARACTER ( REPORT_TYPE : in FUNCTION_CODE ; SIG_CHAR : in CHARACTER ; TERM_SIG_CHAR : in CHARACTER ); -- Assign the signature characters used within report messages -- that the terminal sends to the host. procedure SET_SEGMENT_DETECTABILITY ( SEGMENT : in SEGMENT_IDENTIFIER ; DETECTABLE : in DETECTABILITY ) ; -- Set the detectability of a segment. procedure SET_SEGMENT_DISPLAY_PRIORITY ( SEGMENT : in SEGMENT_IDENTIFIER ; PRIORITY : in PRIORITY_NUMBER ) ; -- Set the display priority of the specified segment. procedure SET_SEGMENT_HIGHLIGHTING ( SEGMENT : in SEGMENT_IDENTIFIER ; HIGHLIGHT : in HIGHLIGHTING ) ; -- Turn highlighting on or off for the specified segment. procedure SET_SEGMENT_POSITION ( SEGMENT : in SEGMENT_IDENTIFIER ; POSITION : in TERMINAL_POINT ) ; -- Move the segment pivot point to the specified position. procedure SET_SEGMENT_VISIBILITY ( SEGMENT : in SEGMENT_IDENTIFIER ; VISIBILITY : in VISIBILITY_MODE ) ; -- Set the specified segment visible or invisible. procedure SET_SNOOPY_MODE ( SNOOPY : in SNOOPY_MODE ) ; -- Specifies whether or not the terminal is in snoopy mode. procedure SET_SURFACE_COLOR_MAP ( SURFACE : in SURFACE_NUMBER ; COLOR_TO_UPDATE : in COLOR_INDEX ; RED_PERCENTAGE : in COLOR_COORDINATE ; GREEN_PERCENTAGE : in COLOR_COORDINATE ; BLUE_PERCENTAGE : in COLOR_COORDINATE ) ; -- Sets the color map for the graphics region procedure SET_SURFACE_DEFINITIONS ( PLANES_IN_1 : in BIT_PLANES ; PLANES_IN_2 : in BIT_PLANES ; PLANES_IN_3 : in BIT_PLANES ; PLANES_IN_4 : in BIT_PLANES ) ; -- Erases the screen and sets the number of surfaces and the -- number of bit planes in each surface. procedure SET_SURFACE_PRIORITIES ( SURFACE_A : in SURFACE_NUMBER ; PRIORITY_A : in SURFACE_PRIORITY ; SURFACE_B : in SURFACE_NUMBER ; PRIORITY_B : in SURFACE_PRIORITY ; SURFACE_C : in SURFACE_NUMBER ; PRIORITY_C : in SURFACE_PRIORITY ; SURFACE_D : in SURFACE_NUMBER ; PRIORITY_D : in SURFACE_PRIORITY ) ; -- Sets the priority of the specified writing surface procedure SET_SURFACE_VISIBILITY ( SURFACE : in SURFACE_NUMBER ; VISIBILITY : in SURFACE_VISIBILITY ) ; -- Set the visibility of a surface without affecting the -- surface priority. procedure SET_TEXT_INDEX ( TEXT_INDEX : in COLOR_INDEX ) ; -- Specify the color index for alphatext and graphtext in the -- graphics area. procedure SET_VIEW_ATTRIBUTES ( SURFACE : in SURFACE_NUMBER ; WIPE_INDEX : in COLOR_INDEX ; BORDER_INDEX : in COLOR_INDEX ) ; -- Sets the surface, wipe index, and border index for the -- current view. procedure SET_VIEWPORT ( FIRST_CORNER : in SCREEN_POINT ; SECOND_CORNER : in SCREEN_POINT ) ; -- Set the position of the current view's viewport in normalized -- screen coordinate space. procedure SET_WINDOW ( FIRST_CORNER : in TERMINAL_POINT ; SECOND_CORNER : in TERMINAL_POINT ) ; -- Set the boundaries of the current view's window in -- terminal space. -- -- SUPPORT PROCEDURES -- procedure TERMINAL_INITIALIZATION ; -- Initialize the Tektronix 4107 display terminal. procedure TERMINAL_TERMINATION ; -- Reset the Tektronix 4107 display terminal for the -- ANSI mode. procedure GRAPHICS_INPUT_REPORT ( KEY_PRESSED : out CHARACTER ; CURSOR_LOCATION : out TERMINAL_POINT ; SEGMENT_NUMBER : out SEGMENT_IDENTIFIER ; PICK_ID_NUMBER : out PICK_ID_IDENTIFIER ) ; -- Retrieve and interpret the graphics input report. procedure SEND_ESCAPE_SEQUENCE_TO_4107( CMD_TEXT : in STRING ) ; -- Send the received command sequence to the terminal. end TEKDRIVER ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --tekdriver_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: with TEXT_IO; use TEXT_IO; package body TEKDRIVER is -- Zero and one integer parameters encoded in host syntax. -- LO-I integer values for zero and one. HOST_SYNTAX_ZERO : constant INTEGER := 2#01_1_0000#; HOST_SYNTAX_ONE : constant INTEGER := 2#01_1_0001#; -- DEBUG_FILE_HANDLE : FILE_TYPE ; -- SUPPORT PROCEDURES -- -- The following procedures are required to support the procedures -- which directly implement the 4107 commands. function HOST_XY ( COORDINATE_POINT : TERMINAL_POINT ) return XY_COORDINATES_STRING is -- Encode the x- and y- coordinate from the input parameter -- coordinate point into five ASCII characters. HI_X : INTEGER range 2#01_00000#..2#01_11111# := 2#01_00000#; HI_Y : INTEGER range 2#01_00000#..2#01_11111# := 2#01_00000#; LO_Y : INTEGER range 2#11_00000#..2#11_11111# := 2#11_00000#; LO_X : INTEGER range 2#10_00000#..2#10_11111# := 2#10_00000#; EXTRA : INTEGER range 2#110_0000#..2#110_1111# := 2#110_0000#; type POINT is ( X, Y ); type HI_LO is ( HIGH, LOW ); INITIAL_XY : array( POINT ) of INTEGER range 0..4095 := ( X => COORDINATE_POINT.X, Y => COORDINATE_POINT.Y ); SHIFT_VALUES : constant array( HI_LO ) of INTEGER := ( HIGH => 2**7, LOW => 2**2 ); MASKED_VALUES : array( POINT, HI_LO ) of INTEGER; HOST_SYNTAX_XY : XY_COORDINATES_STRING; begin for XY in POINT loop for HL in HI_LO loop MASKED_VALUES( XY, HL) := INITIAL_XY( XY ) / SHIFT_VALUES( HL ); if MASKED_VALUES( XY, HL ) > 0 then INITIAL_XY( XY ) := INITIAL_XY( XY ) - ( MASKED_VALUES( XY, HL ) * SHIFT_VALUES( HL ) ); end if; end loop; end loop; HI_X := HI_X + MASKED_VALUES( X, HIGH ); LO_X := LO_X + MASKED_VALUES( X, LOW ); HI_Y := HI_Y + MASKED_VALUES( Y, HIGH ); LO_Y := LO_Y + MASKED_VALUES( Y, LOW ); EXTRA := EXTRA + ( INITIAL_XY( Y ) * ( 2**2 )) + INITIAL_XY( X ); HOST_SYNTAX_XY(1) := CHARACTER'val( HI_Y ); HOST_SYNTAX_XY(2) := CHARACTER'val( EXTRA ); HOST_SYNTAX_XY(3) := CHARACTER'val( LO_Y ); HOST_SYNTAX_XY(4) := CHARACTER'val( HI_X ); HOST_SYNTAX_XY(5) := CHARACTER'val( LO_X ); return HOST_SYNTAX_XY; end HOST_XY; function TERMINAL_XY ( XY_STRING : XY_COORDINATES_STRING ) return TERMINAL_POINT is -- Decode the x- and y- coordinates from the five ASCII -- characters into a coordinate point. -- Define enumeration type corresponding to received string bytes. type BYTES_TYPE is ( HI_Y, EXTRA, LO_Y, HI_X, LO_X ); XY_BYTES : BYTES_TYPE; XY_INTEGERS : array( BYTES_TYPE ) of INTEGER range 0..2#11111#; FIRST_EXTRA : INTEGER range 0..2#1111#; SECOND_EXTRA : INTEGER range 0..2#1111#; XY_POINT : TERMINAL_POINT; TWO_TO_THE_SEVEN : constant INTEGER := 2**7; TWO_TO_THE_TWO : constant INTEGER := 2**2; begin -- Convert received characters into integer equivalents. for BYTE in BYTES_TYPE loop XY_INTEGERS( BYTE ) := CHARACTER'POS( XY_STRING( BYTES_TYPE'POS( BYTE ) + 1 )) - 32; end loop; FIRST_EXTRA := XY_INTEGERS( EXTRA ) / TWO_TO_THE_TWO; SECOND_EXTRA := XY_INTEGERS( EXTRA ) - ( FIRST_EXTRA * TWO_TO_THE_TWO ); XY_POINT.X := ( XY_INTEGERS( HI_X ) * TWO_TO_THE_SEVEN ) + ( XY_INTEGERS( LO_X ) * TWO_TO_THE_TWO ) + SECOND_EXTRA; XY_POINT.Y := ( XY_INTEGERS( HI_Y ) * TWO_TO_THE_SEVEN ) + ( XY_INTEGERS( LO_Y ) * TWO_TO_THE_TWO ) + FIRST_EXTRA; return XY_POINT; end TERMINAL_XY; function HOST_INTEGERS ( X_VALUE : INTEGER ) return TEK_INTEGER_STRING is -- Encode the integer input parameter into three ASCII characters. X : INTEGER range -32767..32767 := X_VALUE; HI_A : INTEGER range 2#1_000000#..2#1_111111# := 2#1_000000#; HI_B : INTEGER range 2#1_000000#..2#1_111111# := 2#1_000000#; LO_I : INTEGER range 2#1_0_0000#..2#1_1_1111# := 2#1_0_0000#; MASKED_VALUE : INTEGER range 0..2#1111_111111_1111#; HI_A_DIV : constant INTEGER := 2**10; HI_B_DIV : constant INTEGER := 2**4; HOST_SYNTAX_INT : TEK_INTEGER_STRING; begin if X < 0 then X := abs ( X ); else LO_I := LO_I + 2#0_1_0000#; end if; MASKED_VALUE := X / HI_A_DIV; if MASKED_VALUE > 0 then X := X - ( MASKED_VALUE * HI_A_DIV ); HI_A := HI_A + MASKED_VALUE; HOST_SYNTAX_INT(1) := CHARACTER'val( HI_A ); else HOST_SYNTAX_INT(1) := STANDARD.ASCII.NUL ; end if; MASKED_VALUE := X / HI_B_DIV; if MASKED_VALUE > 0 then X := X - ( MASKED_VALUE * HI_B_DIV); HI_B := HI_B + MASKED_VALUE; HOST_SYNTAX_INT(2) := CHARACTER'val( HI_B ); else HOST_SYNTAX_INT(2) := STANDARD.ASCII.NUL ; end if; LO_I := LO_I + X; HOST_SYNTAX_INT(3) := CHARACTER'val( LO_I ); return HOST_SYNTAX_INT; end HOST_INTEGERS; function TERMINAL_INTEGERS ( INTEGER_STRING : TEK_INTEGER_STRING ) return INTEGER is -- Decode the integer string input parameter into an integer value. HI_A : INTEGER range 0..2#1_011111#; HI_B : INTEGER range 0..2#1_011111#; LO_I : INTEGER range 0..2#1_1_1111#; SIGN_BIT : INTEGER range -1..1; TWO_TO_THE_TEN : constant INTEGER := 2**10; TWO_TO_THE_FOUR : constant INTEGER := 2**4; INTEGER_REPORT : INTEGER; begin HI_A := CHARACTER'POS( INTEGER_STRING( 1 )) - 32; HI_B := CHARACTER'POS( INTEGER_STRING( 2 )) - 32; LO_I := CHARACTER'POS( INTEGER_STRING( 3 )) - 32; -- If sign bit is zero then integer is negative; -- if sign bit is one then subtract sign bit. SIGN_BIT := LO_I / TWO_TO_THE_FOUR; if SIGN_BIT = 0 then SIGN_BIT := -1; else LO_I := LO_I - TWO_TO_THE_FOUR; end if; INTEGER_REPORT := ( HI_A * TWO_TO_THE_TEN ) + ( HI_B * TWO_TO_THE_FOUR ) + LO_I ; INTEGER_REPORT := INTEGER_REPORT * SIGN_BIT; return INTEGER_REPORT; end TERMINAL_INTEGERS; procedure SEND_TO_4107 ( CMD_TEXT : in STRING ) is -- Send the received command string to the 4107 begin TEXT_IO.PUT( CMD_TEXT ); end SEND_TO_4107; procedure SEND_ESCAPE_SEQUENCE_TO_4107( CMD_TEXT : in STRING ) is -- Send the received command sequence to the terminal. begin SEND_TO_4107( ESC & CMD_TEXT ) ; end SEND_ESCAPE_SEQUENCE_TO_4107 ; procedure TERMINAL_INITIALIZATION is -- Initialize the Tektronix 4107 display terminal. -- Number of dialog lines in the dialog area. DIALOG_AREA_LINES : constant DIALOG_LINES := 24; -- Delete all segments currently stored in the terminal. DELETE_ALL_SEGMENTS : constant SEGMENT_IDENTIFIER := -1; -- Delete all views from the terminal. DELETE_ALL_VIEWS : constant VIEW_NUMBER := -1; -- String used for macro expansion to lock out function keys EXPANSION_STRING : constant STRING := "A" ; -- Define constants for the keys not interpreted during GIN. UNSHIFTED_FUNCTION_1 : constant MACRO_NUMBER := 128 ; SHIFTED_FUNCTION_8 : constant MACRO_NUMBER := 143 ; CTRL_FUNCTION_1 : constant MACRO_NUMBER := -2 ; CTRL_SHIFTED_FUNCTION_8 : constant MACRO_NUMBER := -17 ; RETURN_KEY : constant MACRO_NUMBER := 13 ; SHIFTED_RETURN_KEY : constant MACRO_NUMBER := -49 ; CTRL_RETURN_KEY : constant MACRO_NUMBER := -50 ; CTRL_SHIFTED_RETURN_KEY : constant MACRO_NUMBER := -51 ; ENTER_KEY : constant MACRO_NUMBER := -68 ; SHIFTED_ENTER_KEY : constant MACRO_NUMBER := -82 ; CTRL_ENTER_KEY : constant MACRO_NUMBER := -96 ; CTRL_SHIFTED_ENTER_KEY : constant MACRO_NUMBER := -110; -- Define the initial window boundaries. INITIAL_WINDOW_F_C : constant TERMINAL_POINT := ( X => 0, Y => 0 ); INITIAL_WINDOW_S_C : constant TERMINAL_POINT := ( X => 4095, Y => 3130 ); -- Define the initial viewport boundaries. INITIAL_VIEWPORT_F_C : constant SCREEN_POINT := ( X => 0, Y => 0 ); INITIAL_VIEWPORT_S_C : constant SCREEN_POINT := ( X => 4095, Y => 3071 ); begin -- CREATE ( DEBUG_FILE_HANDLE , TEXT_IO.OUT_FILE , -- "TEKDRIVER_DEBUG.LISTING" ); -- Cause the terminal to recognize Tek commands. SELECT_CODE( TEK ); -- Delete all views. DELETE_VIEW ( DELETE_ALL_VIEWS ); -- Delete all segments. DELETE_SEGMENT ( DELETE_ALL_SEGMENTS ); -- Set the number of surfaces and the bit planes per surface. SET_SURFACE_DEFINITIONS ( 4, 0, 0, 0 ) ; -- Specify view 1 as current view SELECT_VIEW( 1 ); -- Set the surface visibility and the view attributes SET_SURFACE_VISIBILITY( SURFACE_1, SURFACE_VISIBLE ) ; SET_VIEW_ATTRIBUTES( SURFACE_1, 0, 0 ) ; -- Set view border visibility SET_BORDER_VISIBILITY( INVISIBLE ); -- Set the graphtext character path SET_CHARACTER_PATH( RIGHT ) ; -- Set the color mode for the terminal. SET_COLOR_MODE ( RGB, NO_OVERLAY_CHANGE, NO_OPERATION_CHANGE ); -- Erase the dialog buffer. -- CLEAR_DIALOG_SCROLL; -- Set the color map for the graphics region for CURRENT_COLOR in FIRST_COLOR..LAST_COLOR loop SET_SURFACE_COLOR_MAP( SURFACE_1, CURRENT_COLOR, INITIAL_COLORS( CURRENT_COLOR ).RED, INITIAL_COLORS( CURRENT_COLOR ).GREEN, INITIAL_COLORS( CURRENT_COLOR ).BLUE ) ; end loop ; -- Set the color map for the dialog area for CURRENT_COLOR in FIRST_COLOR..DIALOG_LAST_COLOR loop SET_DIALOG_AREA_COLOR_MAP( CURRENT_COLOR, INITIAL_COLORS( CURRENT_COLOR ).RED, INITIAL_COLORS( CURRENT_COLOR ).GREEN, INITIAL_COLORS( CURRENT_COLOR ).BLUE ) ; end loop ; -- Specify the maximum number of lines visible in the dialog area. SET_DIALOG_AREA_LINES ( DIALOG_AREA_LINES ); -- Specify the number of lines in the dialog buffer SET_DIALOG_AREA_BUFFER_SIZE( DIALOG_AREA_LINES ); -- Set color index for alpha characters, character cell -- background, and dialog area background SET_DIALOG_AREA_INDEX( BLUE, 0, 0 ) ; -- Set line style to unbroken line and line color to white SET_LINE_STYLE( 0 ) ; SET_LINE_INDEX( BLUE ) ; -- Set color of background writing surface and specify the -- color indices for the alpha cursor SET_BACKGROUND_COLOR( INITIAL_COLORS( WHITE ).RED, INITIAL_COLORS( WHITE ).GREEN, INITIAL_COLORS( WHITE ).BLUE ) ; SET_ALPHA_CURSOR_INDICES( GREEN, RED ) ; -- Set the size of graphtext characters, and the text color index SET_GRAPHTEXT_SIZE( 20, 20 , 8 ) ; SET_TEXT_INDEX( BLUE ) ; -- Enable the dialog area, and set the dialog area visible ENABLE_DIALOG_AREA ( ENABLE_DIALOG ); SET_DIALOG_AREA_VISIBILITY( VISIBLE ); -- Set the current window boundaries. SET_WINDOW( INITIAL_WINDOW_F_C, INITIAL_WINDOW_S_C ); -- Set the current viewport boundaries. SET_VIEWPORT ( INITIAL_VIEWPORT_F_C, INITIAL_VIEWPORT_S_C ); -- Specify how often the terminal sends an EOL SET_REPORT_EOM_FREQUENCY( LESS_FREQUENT ) ; -- Assign the signature characters to be used within the -- locator report. SET_REPORT_SIG_CHARACTER ( LOCATOR, LOCATOR_SIG_CHAR, LOCATOR_TRM_CHAR ); -- Assign the signature characters to be used within the -- pick report. SET_REPORT_SIG_CHARACTER ( PICK, PICK_SIG_CHAR, PICK_TRM_CHAR ); -- Specify the characters used to terminate messages. SET_EOM_CHARACTERS ( STANDARD.ASCII.CR, STANDARD.ASCII.LF ); -- Specify the color of the crosshair cursor SET_GIN_CURSOR_COLOR( INITIAL_COLORS( BLUE ).RED, INITIAL_COLORS( BLUE ).GREEN, INITIAL_COLORS( BLUE ).BLUE ) ; -- Define key expansion macros for the function keys, the -- return key and the enter key for MACRO_ID in UNSHIFTED_FUNCTION_1..SHIFTED_FUNCTION_8 loop DEFINE_MACRO( MACRO_ID, EXPANSION_STRING ) ; end loop ; for MACRO_ID in reverse CTRL_FUNCTION_1..CTRL_SHIFTED_FUNCTION_8 loop DEFINE_MACRO( MACRO_ID, EXPANSION_STRING ) ; end loop ; DEFINE_MACRO( RETURN_KEY, EXPANSION_STRING ) ; DEFINE_MACRO( SHIFTED_RETURN_KEY, EXPANSION_STRING ) ; DEFINE_MACRO( CTRL_RETURN_KEY, EXPANSION_STRING ) ; DEFINE_MACRO( CTRL_SHIFTED_RETURN_KEY, EXPANSION_STRING ) ; DEFINE_MACRO( ENTER_KEY, EXPANSION_STRING ) ; DEFINE_MACRO( SHIFTED_ENTER_KEY, EXPANSION_STRING ) ; DEFINE_MACRO( CTRL_ENTER_KEY, EXPANSION_STRING ) ; DEFINE_MACRO( CTRL_SHIFTED_ENTER_KEY, EXPANSION_STRING ) ; -- Disable macro key expansion ENABLE_KEY_EXPANSION( DISABLED ) ; -- Cause the terminal to recognize ANSI commands. SELECT_CODE( ANSI ); end TERMINAL_INITIALIZATION ; procedure TERMINAL_TERMINATION is -- Reset the Tektronix 4107 display terminal for the -- ANSI mode. begin SELECT_CODE( TEK ); RESET ; TEXT_IO.PUT_LINE(" ") ; delay 20.0 ; end TERMINAL_TERMINATION ; procedure GRAPHICS_INPUT_REPORT ( KEY_PRESSED : out CHARACTER ; CURSOR_LOCATION : out TERMINAL_POINT ; SEGMENT_NUMBER : out SEGMENT_IDENTIFIER ; PICK_ID_NUMBER : out PICK_ID_IDENTIFIER ) is -- Retrieve and interpret the graphics input report. -- The only graphics input device supported is the joydisk. -- The input functions supported are the LOCATOR and PICK -- -- GIN PICK REPORT GIN LOCATOR REPORT -- -- EOM INDICATOR EOM INDICATOR -- SIG CHAR SIG CHAR -- KEY PRESSED KEY PRESSED -- XY REPORT XY REPORT -- SEGMENT NUMBER EOM INDICATOR -- PICK ID NUMBER TERM SIG CHAR -- EOM INDICATOR EOM INDICATOR -- TERM SIG CHAR -- EOM INDICATOR -- GIN_ERROR : exception; -- GIN report string, report string size, and report type. GIN_STRING : STRING(1..30) := ( others => ' ') ; GIN_CHAR_SIZE : NATURAL; REPORT_TYPE : FUNCTION_CODE; PARAM_STRING : XY_COORDINATES_STRING; -- Final GIN report item string and string size FINAL_STRING : STRING(1..10); FINAL_SIZE : NATURAL; begin -- Retrieve GIN pick report. TEXT_IO.GET_LINE( GIN_STRING, GIN_CHAR_SIZE ); -- TEXT_IO.PUT_LINE(GIN_STRING); -- TEXT_IO.PUT_LINE( " STRING SIZE = " & -- INTEGER'IMAGE(GIN_CHAR_SIZE)); -- Disable macro key expansion ENABLE_KEY_EXPANSION( DISABLED ) ; -- Determine the type GIN report received from the signature -- character. If the signature character is not recognized -- then raise the GIN error exception. if GIN_STRING( 1 ) = LOCATOR_SIG_CHAR then REPORT_TYPE := LOCATOR; elsif GIN_STRING( 1 ) = PICK_SIG_CHAR then REPORT_TYPE := PICK; else raise GIN_ERROR; end if; KEY_PRESSED := GIN_STRING( 2 ); if GIN_STRING( 2 ) /= ' ' then raise GIN_ERROR ; end if ; PARAM_STRING(1..5) := GIN_STRING( 3..7 ) ; CURSOR_LOCATION := TERMINAL_XY( PARAM_STRING ); if REPORT_TYPE = LOCATOR then SEGMENT_NUMBER := 0; PICK_ID_NUMBER := 0; else SEGMENT_NUMBER := TERMINAL_INTEGERS( GIN_STRING( 8..10 ) ); PICK_ID_NUMBER := TERMINAL_INTEGERS( GIN_STRING( 11..13 ) ); end if; exception when GIN_ERROR => -- TEXT_IO.PUT_LINE("INVALID STRING"); -- PUT_LINE (DEBUG_FILE_HANDLE, GIN_STRING) ; -- PUT_LINE (DEBUG_FILE_HANDLE, "STRING SIZE = " & -- INTEGER'IMAGE(GIN_CHAR_SIZE) ); -- Disable all GIN devices. -- DISABLE_GIN ; raise ; end GRAPHICS_INPUT_REPORT ; -- -- COMMAND PROCEDURES FOR THE TEKTRONIX 4107 -- procedure BEGIN_PANEL_BOUNDARY ( FIRST_POINT : in TERMINAL_POINT ; DRAW_BOUNDARY : in BOUNDARY ) is -- Start a panel definition. CMD_STRING : STRING(1..9); begin CMD_STRING(1..3) := ESC & "LP"; CMD_STRING(4..8) := HOST_XY( FIRST_POINT ); CMD_STRING(9) := CHARACTER'val( HOST_SYNTAX_ZERO + BOUNDARY'POS( DRAW_BOUNDARY )); SEND_TO_4107( CMD_STRING ); end BEGIN_PANEL_BOUNDARY ; procedure BEGIN_SEGMENT ( SEGMENT_ID : in SEGMENT_IDENTIFIER ) is -- Begin a new segment, and reset the current pick id to 1. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "SO"; CMD_STRING(4..6) := HOST_INTEGERS( SEGMENT_ID ); SEND_TO_4107( CMD_STRING ); end BEGIN_SEGMENT ; procedure CANCEL is -- Cancel terminal operations and several terminal -- parameters and modes. CMD_STRING : constant STRING(1..3) := ESC & "KC"; begin SEND_TO_4107( CMD_STRING ); end CANCEL ; procedure CLEAR_DIALOG_SCROLL is -- Erase the dialog buffer. CMD_STRING : constant STRING(1..3) := ESC & "LZ"; begin SEND_TO_4107( CMD_STRING ); end CLEAR_DIALOG_SCROLL ; procedure DEFINE_MACRO( MACRO : in MACRO_NUMBER ; TEXT : in STRING ) is -- Create or delete volatile macros STRING_SIZE : constant INTEGER := 9 + ( 3 * TEXT'LENGTH ); CMD_STRING : STRING(1..STRING_SIZE ); FIRST_CHAR : NATURAL ; SECOND_CHAR : NATURAL ; begin CMD_STRING(1..3) := ESC & "KD"; CMD_STRING(4..6) := HOST_INTEGERS( MACRO ) ; CMD_STRING(7..9) := HOST_INTEGERS( TEXT'LENGTH ) ; for N in 1..TEXT'LENGTH loop FIRST_CHAR := NATURAL( 7 + ( N * 3 )); SECOND_CHAR := FIRST_CHAR + 2 ; CMD_STRING(FIRST_CHAR..SECOND_CHAR) := HOST_INTEGERS( CHARACTER'pos(TEXT(N))); end loop ; SEND_TO_4107( CMD_STRING ); end DEFINE_MACRO ; procedure DEFINE_MACRO( MACRO : in MACRO_NUMBER ) is -- Delete volatile macros CMD_STRING : STRING( 1..6 ); begin CMD_STRING(1..3) := ESC & "KD"; CMD_STRING(4..6) := HOST_INTEGERS( MACRO ) ; SEND_TO_4107( CMD_STRING ); end DEFINE_MACRO ; procedure DELETE_SEGMENT ( SEGMENT_ID : in SEGMENT_IDENTIFIER ) is -- Remove a segment from memory. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "SK"; CMD_STRING(4..6) := HOST_INTEGERS( SEGMENT_ID ); SEND_TO_4107( CMD_STRING ); end DELETE_SEGMENT ; procedure DELETE_VIEW ( VIEW_ID : in VIEW_NUMBER ) is -- Delete the specified view. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "RK"; CMD_STRING(4..6) := HOST_INTEGERS( VIEW_ID ); SEND_TO_4107( CMD_STRING ); end DELETE_VIEW ; procedure DISABLE_GIN is -- Disable all GIN devices. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "ID"; CMD_STRING(4..6) := HOST_INTEGERS( -1 ); SEND_TO_4107( CMD_STRING ); end DISABLE_GIN ; procedure DRAW ( POSITION : in TERMINAL_POINT ) is -- Draw a vector from the current graphics position to the -- specified location. CMD_STRING : STRING(1..8); begin CMD_STRING(1..3) := ESC & "LG"; CMD_STRING(4..8) := HOST_XY( POSITION ); SEND_TO_4107( CMD_STRING ); end DRAW ; procedure DRAW_MARKER ( POSITION : in TERMINAL_POINT ) is -- Draw a marker at the specified location. CMD_STRING : STRING(1..8); begin CMD_STRING(1..3) := ESC & "LH"; CMD_STRING(4..8) := HOST_XY( POSITION ); SEND_TO_4107( CMD_STRING ); end DRAW_MARKER ; procedure ENABLE_DIALOG_AREA ( ENABLE_AREA : in DIALOG_MODE ) is -- Enable or disable the dialog area. CMD_STRING : STRING(1..4); begin CMD_STRING(1..3) := ESC & "KA"; CMD_STRING(4) := CHARACTER'val( HOST_SYNTAX_ZERO + DIALOG_MODE'POS( ENABLE_AREA )); SEND_TO_4107( CMD_STRING ); end ENABLE_DIALOG_AREA ; procedure ENABLE_GIN ( DEVICE : in DEVICE_CODE ; GIN_FUNCTION : in FUNCTION_CODE ; NUMBER_OF_EVENTS : in NUMBER_OF_GIN_EVENTS ) is -- Enable the terminal for graphics CMD_STRING : STRING(1..7); begin -- Enable macro key expansion ENABLE_KEY_EXPANSION( ENABLED ) ; CMD_STRING(1..3) := ESC & "IE"; CMD_STRING(4) := CHARACTER'val( HOST_SYNTAX_ZERO + FUNCTION_CODE'POS( GIN_FUNCTION ) ); CMD_STRING(5..7) := HOST_INTEGERS( NUMBER_OF_EVENTS ); SEND_TO_4107( CMD_STRING ); end ENABLE_GIN ; procedure ENABLE_KEY_EXPANSION( EXPANSION : in KEY_EXPANSION ) is -- Enables or disables key macros CMD_STRING : STRING(1..4); begin CMD_STRING(1..3) := ESC & "KW"; CMD_STRING(4) := CHARACTER'val( HOST_SYNTAX_ZERO + KEY_EXPANSION'POS( EXPANSION ) ); SEND_TO_4107( CMD_STRING ); end ENABLE_KEY_EXPANSION ; procedure END_PANEL is -- Terminate a panel definition. CMD_STRING : constant STRING(1..3) := ESC & "LE"; begin SEND_TO_4107( CMD_STRING ); end END_PANEL ; procedure END_SEGMENT is -- Terminate the segment currently being defined. CMD_STRING : constant STRING(1..3) := ESC & "SC"; begin SEND_TO_4107( CMD_STRING ); end END_SEGMENT ; procedure ENTER_ALPHA_MODE is -- Place the terminal in marker mode. CMD_STRING : constant STRING(1..1) := US; begin SEND_TO_4107( CMD_STRING ); end ENTER_ALPHA_MODE ; procedure ENTER_BYPASS_MODE is -- Place the terminal in bypass mode. CMD_STRING : constant STRING(1..1) := CN; begin SEND_TO_4107( CMD_STRING ); end ENTER_BYPASS_MODE ; procedure ENTER_MARKER_MODE is -- Place the terminal in marker mode. CMD_STRING : constant STRING(1..1) := FS; begin SEND_TO_4107( CMD_STRING ); end ENTER_MARKER_MODE ; procedure ENTER_VECTOR_MODE is -- Place the terminal in vector mode. CMD_STRING : constant STRING(1..1) := GS; begin SEND_TO_4107( CMD_STRING ); end ENTER_VECTOR_MODE ; procedure GRAPHIC_TEXT ( TEXT : in STRING ) is -- Write a string of graphtext starting at the current -- graphics position. STRING_SIZE : constant INTEGER := 6 + TEXT'LENGTH; CMD_STRING : STRING(1..STRING_SIZE ); begin CMD_STRING(1..3) := ESC & "LT"; CMD_STRING(4..6) := HOST_INTEGERS( TEXT'LENGTH ); CMD_STRING(7..STRING_SIZE) := TEXT(1..TEXT'LENGTH); SEND_TO_4107( CMD_STRING ); end GRAPHIC_TEXT ; procedure INCLUDE_COPY_OF_SEGMENT ( SEGMENT_ID : in SEGMENT_IDENTIFIER ) is -- Copies another segment into the segment currently being -- defined CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "LK"; CMD_STRING(4..6) := HOST_INTEGERS( SEGMENT_ID ); SEND_TO_4107( CMD_STRING ); end INCLUDE_COPY_OF_SEGMENT ; procedure HARDCOPY ( COPY_CODE : in HARDCOPY_CODE ) is -- Causes an attached hardcopy unit to make a copy of the terminal's -- screen or dialog area. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "KH"; CMD_STRING(4..6) := HOST_INTEGERS( HARDCOPY_CODE'POS( COPY_CODE ) ); SEND_TO_4107( CMD_STRING ); end HARDCOPY ; procedure LOCK_VIEWING_KEYS ( LOCK_KEYS : in LOCKING_MODE ) is -- Locks and unlocks the zoom and pan modes. CMD_STRING : STRING(1..4); begin CMD_STRING(1..3) := ESC & "RJ"; CMD_STRING(4) := CHARACTER'val( HOST_SYNTAX_ZERO + LOCKING_MODE'POS( LOCK_KEYS) ); SEND_TO_4107( CMD_STRING ); end LOCK_VIEWING_KEYS ; procedure MOVE ( POSITION : in TERMINAL_POINT ) is -- Set the current graphics position without drawing a vector. CMD_STRING : STRING(1..8); begin CMD_STRING(1..3) := ESC & "LF"; CMD_STRING(4..8) := HOST_XY( POSITION ); SEND_TO_4107( CMD_STRING ); end MOVE ; procedure PAGE is -- Erase the screen except the dialog area. CMD_STRING : constant STRING(1..2) := ESC & FF; begin SEND_TO_4107( CMD_STRING ); end PAGE ; procedure RENAME_SEGMENT ( OLD_SEGMENT : in SEGMENT_IDENTIFIER ; NEW_SEGMENT : in SEGMENT_IDENTIFIER ) is -- Rename an existing segment. CMD_STRING : STRING(1..9); begin CMD_STRING(1..3) := ESC & "SR"; CMD_STRING(4..6) := HOST_INTEGERS( OLD_SEGMENT ); CMD_STRING(7..9) := HOST_INTEGERS( NEW_SEGMENT ); SEND_TO_4107( CMD_STRING ); end RENAME_SEGMENT ; procedure RENEW_VIEW ( VIEW : in VIEW_NUMBER ) is -- Erase the specified view and redraw all segments visible -- in that view. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "KN"; CMD_STRING(4..6) := HOST_INTEGERS( VIEW ); SEND_TO_4107( CMD_STRING ); end RENEW_VIEW ; procedure REPORT_ERRORS is -- Cause the terminal to send an error report to the host. CMD_STRING : constant STRING(1..3) := ESC & "KQ"; begin SEND_TO_4107( CMD_STRING ); end REPORT_ERRORS ; procedure RESET is -- Returns the terminal to its power_up condition. CMD_STRING : constant STRING(1..3) := ESC & "KV"; begin SEND_TO_4107( CMD_STRING ); end RESET ; procedure SELECT_CODE ( MODE : in TERMINAL_MODE ) is -- Cause the terminal to recognize Ansi, Tek, or VT52 mode -- command syntax. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "%!"; CMD_STRING(4..6) := HOST_INTEGERS( TERMINAL_MODE'POS( MODE ) ); SEND_TO_4107( CMD_STRING ); end SELECT_CODE ; procedure SELECT_FILL_PATTERN ( FILL_PATTERN : in FILL_PATTERN_NUMBER ) is -- Specifies the fill pattern for subsequent panels. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "MP"; CMD_STRING(4..6) := HOST_INTEGERS( FILL_PATTERN ); SEND_TO_4107( CMD_STRING ); end SELECT_FILL_PATTERN ; procedure SELECT_HARDCOPY_INTERFACE ( COPIER : in COPIER_TYPE ) is -- Select the copies type to be used in the HARDCOPY command. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "QD"; CMD_STRING(4..6) := HOST_INTEGERS( COPIER_TYPE'POS( COPIER ) ); SEND_TO_4107( CMD_STRING ); end SELECT_HARDCOPY_INTERFACE ; procedure SELECT_VIEW ( VIEW : in VIEW_NUMBER ) is -- Specifies which view is the current view. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "RC"; CMD_STRING(4..6) := HOST_INTEGERS( VIEW ); SEND_TO_4107( CMD_STRING ); end SELECT_VIEW ; procedure SET_ALPHA_CURSOR_INDICES ( FIRST_COLOR : in COLOR_INDEX ; SECOND_COLOR : in COLOR_INDEX ) is -- Assigns specified color indices to the alpha cursor. CMD_STRING : STRING(1..9); begin CMD_STRING(1..3) := ESC & "TD"; CMD_STRING(4..6) := HOST_INTEGERS( FIRST_COLOR ); CMD_STRING(7..9) := HOST_INTEGERS( SECOND_COLOR ); SEND_TO_4107( CMD_STRING ); end SET_ALPHA_CURSOR_INDICES ; procedure SET_BACKGROUND_COLOR ( FIRST_COLOR : in COLOR_INDEX ; SECOND_COLOR : in COLOR_INDEX ; THIRD_COLOR : in COLOR_INDEX ) is -- Sets the color of the background surface which is behind all -- of the transparent writing surfaces. CMD_STRING : STRING(1..12); begin CMD_STRING(1..3) := ESC & "TB"; CMD_STRING(4..6) := HOST_INTEGERS( FIRST_COLOR ); CMD_STRING(7..9) := HOST_INTEGERS( SECOND_COLOR ); CMD_STRING(10..12) := HOST_INTEGERS( THIRD_COLOR ); SEND_TO_4107( CMD_STRING ); end SET_BACKGROUND_COLOR ; procedure SET_BACKGROUND_INDICES ( TEXT_BACKGROUND_INDEX : in COLOR_INDEX ; DASH_GAP_INDEX : in COLOR_INDEX ) is -- Specifies the color index for the character backgrounds of -- string precision graphtext; also specifies the color index -- used for the gaps in dashed lines. CMD_STRING : STRING(1..9); begin CMD_STRING(1..3) := ESC & "MB"; CMD_STRING(4..6) := HOST_INTEGERS( TEXT_BACKGROUND_INDEX ); CMD_STRING(7..9) := HOST_INTEGERS( DASH_GAP_INDEX ); SEND_TO_4107( CMD_STRING ); end SET_BACKGROUND_INDICES ; procedure SET_BORDER_VISIBILITY ( BORDER_VISIBLE : in VISIBILITY_MODE ) is -- Controls the visibility of a border drawn around the current -- view's viewport. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "RE"; CMD_STRING(4..6) := HOST_INTEGERS( VISIBILITY_MODE'POS( BORDER_VISIBLE )); SEND_TO_4107( CMD_STRING ); end SET_BORDER_VISIBILITY ; procedure SET_CHARACTER_PATH ( PATH : in CHARACTER_DIRECTION ) is -- Specifies the direction to move after writing each -- graphtext character. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "MN"; CMD_STRING(4..6) := HOST_INTEGERS( CHARACTER_DIRECTION'POS( PATH ) ); SEND_TO_4107( CMD_STRING ); end SET_CHARACTER_PATH ; procedure SET_COLOR_MODE ( COLOR_SYSTEM : in COLOR_COORDINATE_SYSTEM ; COLOR_OVERLAY : in COLOR_OVERLAY_TYPE ; COLOR_OR_GRAY : in COLOR_OPERATION_MODE ) is -- Set the color mode for the terminal. CMD_STRING : STRING(1..12); begin CMD_STRING(1..3) := ESC & "TM"; CMD_STRING(4..6) := HOST_INTEGERS( COLOR_COORDINATE_SYSTEM'POS( COLOR_SYSTEM ) ); CMD_STRING(7..9) := HOST_INTEGERS( COLOR_OVERLAY_TYPE'POS( COLOR_OVERLAY ) ); CMD_STRING(10..12) := HOST_INTEGERS( COLOR_OPERATION_MODE'POS( COLOR_OR_GRAY ) ); SEND_TO_4107( CMD_STRING ); end SET_COLOR_MODE ; procedure SET_COPY_SIZE ( IMAGE : in IMAGE_SIZE ) is -- Selects the copy size to produce a standard or reduced image. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "QA"; CMD_STRING(4..6) := HOST_INTEGERS( IMAGE_SIZE'POS( IMAGE ) ); SEND_TO_4107( CMD_STRING ); end SET_COPY_SIZE ; procedure SET_DIALOG_AREA_BUFFER_SIZE ( LINES : in DIALOG_LINES ) is -- Specify the maximum number of lines of text stored in the -- dialog area buffer. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "LB"; CMD_STRING(4..6) := HOST_INTEGERS( LINES ); SEND_TO_4107( CMD_STRING ); end SET_DIALOG_AREA_BUFFER_SIZE ; procedure SET_DIALOG_AREA_COLOR_MAP ( COLOR_TO_UPDATE : in COLOR_INDEX ; RED_PERCENTAGE : in COLOR_COORDINATE ; GREEN_PERCENTAGE : in COLOR_COORDINATE ; BLUE_PERCENTAGE : in COLOR_COORDINATE ) is -- Specify the color assigned to a color index in the dialog area. CMD_STRING : STRING(1..18); begin CMD_STRING(1..3) := ESC & "TF"; CMD_STRING(4..6) := HOST_INTEGERS( 4 ); CMD_STRING(7..9) := HOST_INTEGERS( COLOR_TO_UPDATE ); CMD_STRING(10..12) := HOST_INTEGERS( RED_PERCENTAGE ); CMD_STRING(13..15) := HOST_INTEGERS( GREEN_PERCENTAGE ); CMD_STRING(16..18) := HOST_INTEGERS( BLUE_PERCENTAGE ); SEND_TO_4107( CMD_STRING ); end SET_DIALOG_AREA_COLOR_MAP ; procedure SET_DIALOG_AREA_HARDCOPY_ATTRIBUTES ( PAGES : in NUMBER_OF_PAGES ; ORIGIN : in PAGE_ORIGIN ; FF_INTERPRET : in FORM_FEED_INTERPRETATION ) is -- Specifies the number of pages to be copied, the starting -- page, and how the form feed is interpreted. CMD_STRING : STRING(1..12); begin CMD_STRING(1..3) := ESC & "QL"; CMD_STRING(4..6) := HOST_INTEGERS( PAGES ) ; CMD_STRING(7..9) := HOST_INTEGERS( PAGE_ORIGIN'POS( ORIGIN ) ); CMD_STRING(10..12) := HOST_INTEGERS( FORM_FEED_INTERPRETATION'POS( FF_INTERPRET ) ); SEND_TO_4107( CMD_STRING ); end SET_DIALOG_AREA_HARDCOPY_ATTRIBUTES ; procedure SET_DIALOG_AREA_INDEX ( CHAR_INDEX : in COLOR_INDEX ; CHAR_BACKGROUND_INDEX : in COLOR_INDEX ; DIALOG_BACKGROUND_INDEX : in COLOR_INDEX ) is -- Specify the color index for alphatext characters, character-cell -- background, and dialog area background. CMD_STRING : STRING(1..12); begin CMD_STRING(1..3) := ESC & "LI"; CMD_STRING(4..6) := HOST_INTEGERS( CHAR_INDEX ); CMD_STRING(7..9) := HOST_INTEGERS( CHAR_BACKGROUND_INDEX ); CMD_STRING(10..12) := HOST_INTEGERS( DIALOG_BACKGROUND_INDEX ); SEND_TO_4107( CMD_STRING ); end SET_DIALOG_AREA_INDEX ; procedure SET_DIALOG_AREA_LINES ( LINES : in DIALOG_LINES ) is -- Specify the maximum number of lines visible in the dialog area. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "LL"; CMD_STRING(4..6) := HOST_INTEGERS( LINES ); SEND_TO_4107( CMD_STRING ); end SET_DIALOG_AREA_LINES ; procedure SET_DIALOG_AREA_VISIBILITY ( AREA_VISIBLE : in VISIBILITY_MODE ) is -- Specifies whether the dialog area is visible or invisible. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "LV"; CMD_STRING(4..6) := HOST_INTEGERS( VISIBILITY_MODE'POS( AREA_VISIBLE ) ); SEND_TO_4107( CMD_STRING ); end SET_DIALOG_AREA_VISIBILITY ; procedure SET_EOM_CHARACTERS ( FIRST_EOM : in CHARACTER ; SECOND_EOM : in CHARACTER ) is -- Specifies the characters used to terminate messages. CMD_STRING : STRING(1..9); begin CMD_STRING(1..3) := ESC & "NC"; CMD_STRING(4..6) := HOST_INTEGERS( CHARACTER'POS( FIRST_EOM ) ); CMD_STRING(7..9) := HOST_INTEGERS( CHARACTER'POS( SECOND_EOM ) ); SEND_TO_4107( CMD_STRING ); end SET_EOM_CHARACTERS ; procedure SET_ERROR_THRESHOLD ( ERROR_DISPLAY : in ERROR_DISPLAY_LEVEL ) is -- Specifies the levels of error messages the terminal displays CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "KT"; CMD_STRING(4..6) := HOST_INTEGERS( ERROR_DISPLAY_LEVEL'POS( ERROR_DISPLAY ) ); SEND_TO_4107( CMD_STRING ); end SET_ERROR_THRESHOLD ; procedure SET_GIN_CURSOR_COLOR ( RED_PERCENTAGE : in COLOR_COORDINATE ; GREEN_PERCENTAGE : in COLOR_COORDINATE ; BLUE_PERCENTAGE : in COLOR_COORDINATE ) is -- Specifies the color mixture for the graphics crosshair cursor. CMD_STRING : STRING(1..12); begin CMD_STRING(1..3) := ESC & "TC"; CMD_STRING(4..6) := HOST_INTEGERS( RED_PERCENTAGE ); CMD_STRING(7..9) := HOST_INTEGERS( GREEN_PERCENTAGE ); CMD_STRING(10..12) := HOST_INTEGERS( BLUE_PERCENTAGE ); SEND_TO_4107( CMD_STRING ); end SET_GIN_CURSOR_COLOR ; procedure SET_GIN_DISPLAY_START_POINT ( DEVICE : in DEVICE_CODE ; GIN_FUNCTION : in FUNCTION_CODE ; START_POINT : in TERMINAL_POINT ) is -- Specifies an initial point for GIN inking or GIN rubberbanding. CMD_STRING : STRING(1..11); begin CMD_STRING(1..3) := ESC & "IX"; CMD_STRING(4..6) := HOST_INTEGERS( FUNCTION_CODE'POS( GIN_FUNCTION ) ); CMD_STRING(7..11) := HOST_XY( START_POINT ); SEND_TO_4107( CMD_STRING ); end SET_GIN_DISPLAY_START_POINT ; procedure SET_GIN_RUBBERBANDING ( DEVICE : in DEVICE_CODE ; GIN_FUNCTION : in FUNCTION_CODE ; RUBBERBANDING : in RUBBERBANDING_MODE ) is -- Turns rubberbanding on or off for all subsequent operations of -- the specified Locator function. CMD_STRING : STRING(1..9); begin CMD_STRING(1..3) := ESC & "IX"; CMD_STRING(4..6) := HOST_INTEGERS( FUNCTION_CODE'POS( GIN_FUNCTION ) ); CMD_STRING(7..9) := HOST_INTEGERS( RUBBERBANDING_MODE'POS( RUBBERBANDING ) ); SEND_TO_4107( CMD_STRING ); end SET_GIN_RUBBERBANDING ; procedure SET_GRAPHTEXT_PRECISION ( PRECISION : in GRAPHTEXT_PRECISION ) is -- Selects string-precision or stroke-precision to draw graphtext -- characters. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "MQ"; CMD_STRING(4..6) := HOST_INTEGERS( GRAPHTEXT_PRECISION'POS( PRECISION ) ); SEND_TO_4107( CMD_STRING ); end SET_GRAPHTEXT_PRECISION ; procedure SET_GRAPHTEXT_SIZE ( WIDTH : in TERMINAL_COORDINATE ; HEIGHT : in TERMINAL_COORDINATE ; SPACING : in TERMINAL_COORDINATE ) is -- Set the size of graphics text. CMD_STRING : STRING(1..12); begin CMD_STRING(1..3) := ESC & "MC"; CMD_STRING(4..6) := HOST_INTEGERS( WIDTH ) ; CMD_STRING(7..9) := HOST_INTEGERS( HEIGHT ) ; CMD_STRING(10..12) := HOST_INTEGERS( SPACING ) ; SEND_TO_4107( CMD_STRING ); end SET_GRAPHTEXT_SIZE ; procedure SET_LINE_INDEX ( LINE_INDEX : in COLOR_INDEX ) is -- Specify the color index for all subsequent lines, -- panel boundaries, and markers. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "ML"; CMD_STRING(4..6) := HOST_INTEGERS( LINE_INDEX ); SEND_TO_4107( CMD_STRING ); end SET_LINE_INDEX ; procedure SET_LINE_STYLE ( LINE : in LINE_STYLE ) is -- Specify the line style for subsequent lines and panel boundaries. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "MV"; CMD_STRING(4..6) := HOST_INTEGERS( LINE_STYLE'POS( LINE ) ); SEND_TO_4107( CMD_STRING ); end SET_LINE_STYLE ; procedure SET_MARKER_TYPE ( MARKER : in MARKER_NUMBER ) is -- Specify the marker style. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "MM"; CMD_STRING(4..6) := HOST_INTEGERS( MARKER_NUMBER'POS( MARKER ) ); SEND_TO_4107( CMD_STRING ); end SET_MARKER_TYPE ; procedure SET_PICK_APERTURE ( APERTURE_WIDTH : in TERMINAL_COORDINATE ) is -- Sets the size of the GIN cursor aperture used to pick segments. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "IA"; CMD_STRING(4..6) := HOST_INTEGERS( APERTURE_WIDTH ); SEND_TO_4107( CMD_STRING ); end SET_PICK_APERTURE ; procedure SET_PICK_ID ( PICK_ID : in PICK_ID_IDENTIFIER ) is -- Mark the next xy location added to the currently open segment -- as a pick point and assign the specified identification number. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "MI"; CMD_STRING(4..6) := HOST_INTEGERS( PICK_ID ); SEND_TO_4107( CMD_STRING ); end SET_PICK_ID ; procedure SET_PIVOT_POINT ( PIVOT_POINT : in TERMINAL_POINT ) is -- Specify the pivot point for subsequent segment definitions. CMD_STRING : STRING(1..8); begin CMD_STRING(1..3) := ESC & "SP"; CMD_STRING(4..8) := HOST_XY( PIVOT_POINT ); SEND_TO_4107( CMD_STRING ); end SET_PIVOT_POINT ; procedure SET_QUEUE_SIZE ( QUEUE_SIZE : in INPUT_QUEUE_SIZE ) is -- Specifies the size in bytes of the terminal's input queue -- for RS-232 communications. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "NQ"; CMD_STRING(4..6) := HOST_INTEGERS( QUEUE_SIZE ) ; SEND_TO_4107( CMD_STRING ); end SET_QUEUE_SIZE ; procedure SET_REPORT_EOM_FREQUENCY ( FREQUENCY : in EOM_FREQUENCY ) is -- Specifies how often the terminal sends an EOL string to -- the host CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "IM"; CMD_STRING(4..6) := HOST_INTEGERS( EOM_FREQUENCY'POS( FREQUENCY ) ); SEND_TO_4107( CMD_STRING ); end SET_REPORT_EOM_FREQUENCY ; procedure SET_REPORT_SIG_CHARACTER ( REPORT_TYPE : in FUNCTION_CODE ; SIG_CHAR : in CHARACTER ; TERM_SIG_CHAR : in CHARACTER ) is -- Assign the signature characters used within report messages -- that the terminal sends to the host. CMD_STRING : STRING(1..10); begin CMD_STRING(1..3) := ESC & "IS"; CMD_STRING(4) := CHARACTER'val( HOST_SYNTAX_ZERO + FUNCTION_CODE'pos( REPORT_TYPE ) ); CMD_STRING(5..7) := HOST_INTEGERS( CHARACTER'pos( SIG_CHAR ) ); CMD_STRING(8..10) := HOST_INTEGERS( CHARACTER'pos( TERM_SIG_CHAR ) ); SEND_TO_4107( CMD_STRING ); end SET_REPORT_SIG_CHARACTER ; procedure SET_SEGMENT_DETECTABILITY ( SEGMENT : in SEGMENT_IDENTIFIER ; DETECTABLE : in DETECTABILITY ) is -- Set the detectability of a segment. CMD_STRING : STRING(1..7); begin CMD_STRING(1..3) := ESC & "SD"; CMD_STRING(4..6) := HOST_INTEGERS( SEGMENT ); CMD_STRING(7) := CHARACTER'val( HOST_SYNTAX_ZERO + DETECTABILITY'POS( DETECTABLE ) ); SEND_TO_4107( CMD_STRING ); end SET_SEGMENT_DETECTABILITY ; procedure SET_SEGMENT_DISPLAY_PRIORITY ( SEGMENT : in SEGMENT_IDENTIFIER ; PRIORITY : in PRIORITY_NUMBER ) is -- Set the display priority of the specified segment. CMD_STRING : STRING(1..9); begin CMD_STRING(1..3) := ESC & "SS"; CMD_STRING(4..6) := HOST_INTEGERS( SEGMENT ); CMD_STRING(7..9) := HOST_INTEGERS( PRIORITY ); SEND_TO_4107( CMD_STRING ); end SET_SEGMENT_DISPLAY_PRIORITY ; procedure SET_SEGMENT_HIGHLIGHTING ( SEGMENT : in SEGMENT_IDENTIFIER ; HIGHLIGHT : in HIGHLIGHTING ) is -- Turn highlighting on or off for the specified segment. CMD_STRING : STRING(1..7); begin CMD_STRING(1..3) := ESC & "SH"; CMD_STRING(4..6) := HOST_INTEGERS( SEGMENT ); CMD_STRING(7) := CHARACTER'val( HOST_SYNTAX_ZERO + HIGHLIGHTING'POS( HIGHLIGHT ) ); SEND_TO_4107( CMD_STRING ); end SET_SEGMENT_HIGHLIGHTING ; procedure SET_SEGMENT_POSITION ( SEGMENT : in SEGMENT_IDENTIFIER ; POSITION : in TERMINAL_POINT ) is -- Move the segment pivot point to the specified position. CMD_STRING : STRING(1..11); begin CMD_STRING(1..3) := ESC & "SX"; CMD_STRING(4..6) := HOST_INTEGERS( SEGMENT ); CMD_STRING(7..11) := HOST_XY( POSITION ); SEND_TO_4107( CMD_STRING ); end SET_SEGMENT_POSITION ; procedure SET_SEGMENT_VISIBILITY ( SEGMENT : in SEGMENT_IDENTIFIER ; VISIBILITY : in VISIBILITY_MODE ) is -- Set the specified segment visible or invisible. CMD_STRING : STRING(1..7); begin CMD_STRING(1..3) := ESC & "SV"; CMD_STRING(4..6) := HOST_INTEGERS( SEGMENT ); CMD_STRING(7) := CHARACTER'val( HOST_SYNTAX_ZERO + VISIBILITY_MODE'POS( VISIBILITY ) ); SEND_TO_4107( CMD_STRING ); end SET_SEGMENT_VISIBILITY ; procedure SET_SNOOPY_MODE ( SNOOPY : in SNOOPY_MODE ) is -- Specifies whether or not the terminal is in snoopy mode. CMD_STRING : STRING(1..4); begin CMD_STRING(1..3) := ESC & "KS"; CMD_STRING(4) := CHARACTER'val( HOST_SYNTAX_ZERO + SNOOPY_MODE'POS( SNOOPY ) ); SEND_TO_4107( CMD_STRING ); end SET_SNOOPY_MODE ; procedure SET_SURFACE_COLOR_MAP ( SURFACE : in SURFACE_NUMBER ; COLOR_TO_UPDATE : in COLOR_INDEX ; RED_PERCENTAGE : in COLOR_COORDINATE ; GREEN_PERCENTAGE : in COLOR_COORDINATE ; BLUE_PERCENTAGE : in COLOR_COORDINATE ) is -- Sets the color map for the graphics region CMD_STRING : STRING(1..21); begin CMD_STRING(1..3) := ESC & "TG"; CMD_STRING(4..6) := HOST_INTEGERS( SURFACE ); CMD_STRING(7..9) := HOST_INTEGERS( 4 ); CMD_STRING(10..12) := HOST_INTEGERS( COLOR_TO_UPDATE ); CMD_STRING(13..15) := HOST_INTEGERS( RED_PERCENTAGE ); CMD_STRING(16..18) := HOST_INTEGERS( GREEN_PERCENTAGE ); CMD_STRING(19..21) := HOST_INTEGERS( BLUE_PERCENTAGE ); SEND_TO_4107( CMD_STRING ); end SET_SURFACE_COLOR_MAP ; procedure SET_SURFACE_DEFINITIONS ( PLANES_IN_1 : in BIT_PLANES ; PLANES_IN_2 : in BIT_PLANES ; PLANES_IN_3 : in BIT_PLANES ; PLANES_IN_4 : in BIT_PLANES ) is -- Erases the screen and sets the number of surfaces and the -- number of bit planes in each surface. CMD_STRING : STRING(1..18); begin CMD_STRING(1..3) := ESC & "RD"; CMD_STRING(4..6) := HOST_INTEGERS( 4 ); CMD_STRING(7..9) := HOST_INTEGERS( PLANES_IN_1 ); CMD_STRING(10..12) := HOST_INTEGERS( PLANES_IN_2 ); CMD_STRING(13..15) := HOST_INTEGERS( PLANES_IN_3 ); CMD_STRING(16..18) := HOST_INTEGERS( PLANES_IN_4 ); SEND_TO_4107( CMD_STRING ); end SET_SURFACE_DEFINITIONS ; procedure SET_SURFACE_PRIORITIES ( SURFACE_A : in SURFACE_NUMBER ; PRIORITY_A : in SURFACE_PRIORITY ; SURFACE_B : in SURFACE_NUMBER ; PRIORITY_B : in SURFACE_PRIORITY ; SURFACE_C : in SURFACE_NUMBER ; PRIORITY_C : in SURFACE_PRIORITY ; SURFACE_D : in SURFACE_NUMBER ; PRIORITY_D : in SURFACE_PRIORITY ) is -- Sets the priority of the specified writing surface CMD_STRING : STRING(1..30); begin CMD_STRING(1..3) := ESC & "RN"; CMD_STRING(4..6) := HOST_INTEGERS( 8 ); CMD_STRING(7..9) := HOST_INTEGERS( SURFACE_A ); CMD_STRING(10..12) := HOST_INTEGERS( PRIORITY_A ); CMD_STRING(13..15) := HOST_INTEGERS( SURFACE_B ); CMD_STRING(16..18) := HOST_INTEGERS( PRIORITY_B ); CMD_STRING(19..21) := HOST_INTEGERS( SURFACE_C ); CMD_STRING(22..24) := HOST_INTEGERS( PRIORITY_C ); CMD_STRING(25..27) := HOST_INTEGERS( SURFACE_D ); CMD_STRING(28..30) := HOST_INTEGERS( PRIORITY_D ); SEND_TO_4107( CMD_STRING ); end SET_SURFACE_PRIORITIES ; procedure SET_SURFACE_VISIBILITY ( SURFACE : in SURFACE_NUMBER ; VISIBILITY : in SURFACE_VISIBILITY ) is -- Set the visibility of a surface without affecting the -- surface priority. CMD_STRING : STRING(1..10); begin CMD_STRING(1..3) := ESC & "RI"; CMD_STRING(4..6) := HOST_INTEGERS( 2 ); CMD_STRING(7..9) := HOST_INTEGERS( SURFACE ); CMD_STRING(10) := CHARACTER'val( HOST_SYNTAX_ZERO + SURFACE_VISIBILITY'POS( VISIBILITY ) ); SEND_TO_4107( CMD_STRING ); end SET_SURFACE_VISIBILITY ; procedure SET_TEXT_INDEX ( TEXT_INDEX : in COLOR_INDEX ) is -- Specify the color index for alphatext and graphtext in the -- graphics area. CMD_STRING : STRING(1..6); begin CMD_STRING(1..3) := ESC & "MT"; CMD_STRING(4..6) := HOST_INTEGERS( TEXT_INDEX ); SEND_TO_4107( CMD_STRING ); end SET_TEXT_INDEX ; procedure SET_VIEW_ATTRIBUTES ( SURFACE : in SURFACE_NUMBER ; WIPE_INDEX : in COLOR_INDEX ; BORDER_INDEX : in COLOR_INDEX ) is -- Sets the surface, wipe index, and border index for the -- current view. CMD_STRING : STRING(1..12); begin CMD_STRING(1..3) := ESC & "RA"; CMD_STRING(4..6) := HOST_INTEGERS( SURFACE ); CMD_STRING(7..9) := HOST_INTEGERS( WIPE_INDEX ); CMD_STRING(10..12) := HOST_INTEGERS( BORDER_INDEX ); SEND_TO_4107( CMD_STRING ); end SET_VIEW_ATTRIBUTES ; procedure SET_VIEWPORT ( FIRST_CORNER : in SCREEN_POINT ; SECOND_CORNER : in SCREEN_POINT ) is -- Set the position of the current view's viewport in normalized -- screen coordinate space. CMD_STRING : STRING(1..13); TERMINAL_CORNER : TERMINAL_POINT; begin CMD_STRING(1..3) := ESC & "RV"; -- Perform explicit conversion of type SCREEN_POINT to -- type TERMINAL_POINT prior to calling the conversion routine. TERMINAL_CORNER.X := FIRST_CORNER.X; TERMINAL_CORNER.Y := TERMINAL_COORDINATE( FIRST_CORNER.Y ); CMD_STRING(4..8) := HOST_XY( TERMINAL_CORNER ); TERMINAL_CORNER.X := SECOND_CORNER.X; TERMINAL_CORNER.Y := TERMINAL_COORDINATE( SECOND_CORNER.Y ); CMD_STRING(9..13) := HOST_XY( TERMINAL_CORNER ); SEND_TO_4107( CMD_STRING ); end SET_VIEWPORT ; procedure SET_WINDOW ( FIRST_CORNER : in TERMINAL_POINT ; SECOND_CORNER : in TERMINAL_POINT ) is -- Set the boundaries of the current view's window in -- terminal space. CMD_STRING : STRING(1..13); begin CMD_STRING(1..3) := ESC & "RW"; CMD_STRING(4..8) := HOST_XY( FIRST_CORNER ); CMD_STRING(9..13) := HOST_XY( SECOND_CORNER ); SEND_TO_4107( CMD_STRING ); end SET_WINDOW ; begin ESC(1) := STANDARD.ASCII.ESC; FF(1) := STANDARD.ASCII.FF; FS(1) := STANDARD.ASCII.FS; GS(1) := STANDARD.ASCII.GS; US(1) := STANDARD.ASCII.US; CN(1) := STANDARD.ASCII.CAN; -- Increase the terminal input buffer size SELECT_CODE( TEK ); SET_QUEUE_SIZE( 10000 ) ; --CANCEL; TERMINAL_INITIALIZATION ; -- Cause the terminal to recognize ANSI commands. SELECT_CODE( ANSI ); end TEKDRIVER ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --trace_pkg_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-07-24 16:00 by RAM with TEXT_IO ; use TEXT_IO ; package TRACE_PKG is --------------------------------------------------------------------------- -- -- This package provides a procedure to write Trace messages to a -- text output file. -- --------------------------------------------------------------------------- procedure TRACE (MESSAGE: in STRING) ; ------------------------------------------------------------------------ -- This procedure outputs the message to the trace file. ------------------------------------------------------------------------ procedure CLOSE_TRACE_FILE ; ------------------------------------------------------------------------ -- This procedure closes the trace file. ------------------------------------------------------------------------ REQUEST_TRACE : Boolean ; ------------------------------------------------------------------------ -- This is the globel flag to execute calls to trace, init in body. ------------------------------------------------------------------------ end TRACE_PKG ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --trace_pkg_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-11-26 10:15 by RAM package body TRACE_PKG is TRACE_FILE_HANDLE : FILE_TYPE ; procedure TRACE (MESSAGE: in STRING) is ------------------------------------------------------------------------ -- This procedure outputs the message to the trace file. ------------------------------------------------------------------------ begin if not TEXT_IO.IS_OPEN( TRACE_FILE_HANDLE ) then -- Create the current trace file CREATE( TRACE_FILE_HANDLE , TEXT_IO.OUT_FILE , "CODE_TRACE_FILE.LISTING" ); end if ; PUT_LINE (TRACE_FILE_HANDLE, MESSAGE) ; exception when others => PUT_LINE (" error in TRACE_PKG") ; end TRACE ; procedure CLOSE_TRACE_FILE is ------------------------------------------------------------------------ -- This procedure closes the trace file. ------------------------------------------------------------------------ begin if TEXT_IO.IS_OPEN( TRACE_FILE_HANDLE ) then CLOSE (TRACE_FILE_HANDLE) ; end if ; end CLOSE_TRACE_FILE ; begin -- initialize the value for request trace --- REQUEST_TRACE := True ; REQUEST_TRACE := False ; end TRACE_PKG ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --tree_data_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-12-11 0840 by JL with GRAPHICS_DATA; use GRAPHICS_DATA; package TREE_DATA is ------------------------------------------------------------------------- -- -- This package provides the declarations and objects for the -- Graph Tree which holds all the graphical, syntax, and -- semantic information required by the program. The tree contains -- TREE, LIST and GRAPH nodes. The TREE nodes represent Ada -- entities (structures) and are connected in a hierarchal order (tree) -- indicating the scope of each entity. The LIST nodes are used to -- store relationships (e.g., context clauses) and annotations (e.g., -- exported type declarations). The GRAPH nodes contain the graphical -- data associated with each TREE node. -- ------------------------------------------------------------------------- ---------------------------------------------------------------------- -- All of the Ada entities, one for each type of TREE node. ---------------------------------------------------------------------- type ENTITY_TYPE is (UNUSED, ROOT, TYPE_VIRTUAL_PACKAGE, TYPE_PACKAGE, TYPE_PROCEDURE, TYPE_FUNCTION, TYPE_TASK, TYPE_ENTRY_POINT, TYPE_BODY, IMPORTED_VIRTUAL_PACKAGE, IMPORTED_PACKAGE, IMPORTED_PROCEDURE, IMPORTED_FUNCTION, EXPORTED_PROCEDURE, EXPORTED_FUNCTION, EXPORTED_ENTRY_POINT, EXPORTED_TYPE, EXPORTED_OBJECT, EXPORTED_EXCEPTION, CONNECTION_BY_CALL, CONNECTION_FOR_DATA); ---------------------------------------------------------------------- -- ENTITY names ---------------------------------------------------------------------- MAXIMUM_NAME_LENGTH : constant POSITIVE := 80 ; subtype NAME_TYPE is STRING (1..MAXIMUM_NAME_LENGTH) ; NULL_NAME : constant NAME_TYPE := (others => ' ') ; ---------------------------------------------------------------------- -- GENERIC information ---------------------------------------------------------------------- type GENERIC_STATUS_TYPE is (NOT_GENERIC, GENERIC_DECLARATION, GENERIC_INSTANTIATION); ---------------------------------------------------------------------- -- TASK information ---------------------------------------------------------------------- type TASK_STATUS_TYPE is (NORMAL_TASK, TASK_TYPE_DECLARATION, TASK_TYPE_OBJECT); ---------------------------------------------------------------------- -- The ACCESS types ---------------------------------------------------------------------- -- The access type for GRAPH_NODEs, implemented as an -- index into GRAPH array. subtype GRAPH_NODE_ACCESS_TYPE is INTEGER; -- The access type for LIST_NODEs, implemented as an -- index into LIST array. subtype LIST_NODE_ACCESS_TYPE is INTEGER; -- The access index of TREE_NODE_TYPEs. A negative number -- will indicate a 'NULL' pointer. subtype TREE_NODE_ACCESS_TYPE is INTEGER; -- The access type for PROLOGUE_NODEs, implemented as an -- index into PROLOGUE array. subtype PROLOGUE_NODE_ACCESS_TYPE is INTEGER; -- To be used to initialize the access values to indicate it -- is not currently pointing to anything. NULL_POINTER : INTEGER := -1; ---------------------------------------------------------------------- -- The graphical data for each tree node, stored in the -- GRAPH_DATA_ARRAY. A null OWNING_TREE_NODE indicates that -- the node is unused. ---------------------------------------------------------------------- type GRAPH_NODE_TYPE is record OWNING_TREE_NODE : TREE_NODE_ACCESS_TYPE := NULL_POINTER; DATA : GRAPHICS_DATA.GRAPHICS_DATA_TYPE; end record; ---------------------------------------------------------------------- -- The PROLOGUE data for each tree node of type virtual package, -- package, procedure, function, and task. A null OWNING_TREE_NODE -- indicates that the node is unused. ---------------------------------------------------------------------- PROLOGUE_COUNT : constant NATURAL := 3 ; PROLOGUE_LINE_SIZE : constant NATURAL := 75 ; subtype PROLOGUE_LINE is STRING (1..PROLOGUE_LINE_SIZE) ; type PROLOGUE_LINE_ARRAY is array (1..PROLOGUE_COUNT) of PROLOGUE_LINE ; type PROLOGUE_NODE_TYPE is record OWNING_TREE_NODE : TREE_NODE_ACCESS_TYPE := NULL_POINTER; DATA : PROLOGUE_LINE_ARRAY := (others => (others => ' ')) ; end record; ---------------------------------------------------------------------- -- The LINE type is used to define connecting lines between -- graphic entities (Call, Export, and Ada 'Use' connections). -- A line is a series of points which define line segments -- comprising the connection line. ---------------------------------------------------------------------- MAXIMUM_NO_LINE_SEGMENTS : constant INTEGER := 20; subtype POINTS is GRAPH_NODE_ACCESS_TYPE; type LINE_TYPE is array (1..MAXIMUM_NO_LINE_SEGMENTS) of POINTS; NULL_LINE : constant LINE_TYPE := ( others => NULL_POINTER ) ; ---------------------------------------------------------------------- -- The various LISTS occuring in the tree are declared below. -- The list format to be used to create specific kinds of lists. -- A doubly linked list is required for forward and back tracing. ---------------------------------------------------------------------- -- The lists contained in a Tree Node. The order of the Lists -- is the order of the List scan during a tree walk. type LIST_TYPE is (START, -- for starting node list scans CONTAINED_LIST, CALLEE_LIST, DATA_CONNECT_LIST, ENTRY_LIST, EXPORTED_LIST, IMPORTED_LIST, NULL_LIST); -- The list structures of the Tree are created from the list -- nodes declared below, which link Tree nodes. Each List -- node is associated with a Tree node (ITEM), and hence a null -- ITEM indicates an unused node. type LIST_NODE_TYPE is record ITEM : TREE_NODE_ACCESS_TYPE := NULL_POINTER; PRIOR : LIST_NODE_ACCESS_TYPE := NULL_POINTER; NEXT : LIST_NODE_ACCESS_TYPE := NULL_POINTER; -- for use in Membership Lists REF_COUNT : NATURAL := 0; -- count of refs by ITEM to List Owner MEMBER_OF : LIST_TYPE := NULL_LIST; -- the refering list type end record; -- A list of all called entities and their connections. subtype CALLEE_LIST_TYPE is LIST_NODE_ACCESS_TYPE; -- A list of all contained entities. subtype CONTAINED_ENTITY_LIST_TYPE is LIST_NODE_ACCESS_TYPE; -- A list of all Data connections for an entity subtype DATA_CONNECT_LIST_TYPE is LIST_NODE_ACCESS_TYPE; -- A list of all the entries for a task. subtype ENTRY_LIST_TYPE is LIST_NODE_ACCESS_TYPE; -- A list of all exported entities. subtype EXPORTED_LIST_TYPE is LIST_NODE_ACCESS_TYPE; -- A list of all imported entities. subtype IMPORTED_LIST_TYPE is LIST_NODE_ACCESS_TYPE; ---------------------------------------------------------------------- -- The definition of the MEMBERSHIP list. ---------------------------------------------------------------------- -- The MEMBERSHIP list exists to maintain a back pointer for -- relations established by other lists. The TREE_OPS package -- should be the only manipulator of this list. -- -- The access type for the MEMBERSHIP list, is implemented as an -- index into LIST array. This is done to minimize the number -- of node types to be handled. subtype MEMBERSHIP_LIST_TYPE is LIST_NODE_ACCESS_TYPE; ---------------------------------------------------------------------- -- The definition of the TREE node structure. This data structure -- is combined using the LIST data structure to form a DIANA like -- syntax tree which stores the syntactical and semantic information -- concerning the Ada program which is represented by the OODD under -- construction. A predefined Root Node is as the starting point -- of each Tree. ---------------------------------------------------------------------- type TREE_NODE_TYPE (NODE_TYPE: ENTITY_TYPE := UNUSED) is record NAME : NAME_TYPE := NULL_NAME; -- the name of this node PARENT : TREE_NODE_ACCESS_TYPE := NULL_POINTER; -- the parent GRAPH_DATA : GRAPH_NODE_ACCESS_TYPE := NULL_POINTER; ------------------------------------------------------------------- -- A list of all list nodes pointing to this node ------------------------------------------------------------------- MEMBERSHIP : MEMBERSHIP_LIST_TYPE := NULL_POINTER; ------------------------------------------------------------------- -- The Node Type specific data which includes lists pointing -- to connected, contained, or related nodes, and which includes -- semantic information concerning the current node (e.g., -- generic status of a subprogram). ------------------------------------------------------------------- case NODE_TYPE is when ROOT | TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE | TYPE_PROCEDURE | TYPE_FUNCTION | TYPE_TASK => CONTAINED_ENTITY_LIST : CONTAINED_ENTITY_LIST_TYPE := NULL_POINTER; case NODE_TYPE is when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE | TYPE_PROCEDURE | TYPE_FUNCTION | TYPE_TASK => PROLOGUE_PTR : PROLOGUE_NODE_ACCESS_TYPE := NULL_POINTER; BODY_PTR : TREE_NODE_ACCESS_TYPE := NULL_POINTER; DATA_CONNECT_LIST : DATA_CONNECT_LIST_TYPE := NULL_POINTER; case NODE_TYPE is when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE | TYPE_PROCEDURE | TYPE_FUNCTION => GENERIC_STATUS : GENERIC_STATUS_TYPE := NOT_GENERIC; CU_INSTANTIATED : NAME_TYPE := NULL_NAME; case NODE_TYPE is when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE => EXPORTED_LIST : EXPORTED_LIST_TYPE := NULL_POINTER; IMPORTED_LIST : IMPORTED_LIST_TYPE := NULL_POINTER; when TYPE_FUNCTION | TYPE_PROCEDURE => HAS_PARAMETERS : BOOLEAN := FALSE; when others => null; end case; when TYPE_TASK => TASK_STATUS : TASK_STATUS_TYPE := NORMAL_TASK; ENTRY_LIST : ENTRY_LIST_TYPE := NULL_POINTER; when others => null; end case; when others => null ; end case ; when TYPE_ENTRY_POINT => IS_GUARDED : BOOLEAN := FALSE; -- for task entry points WITH_PARAMETERS : BOOLEAN := FALSE; when TYPE_BODY => CALLEE_LIST : CALLEE_LIST_TYPE := NULL_POINTER; when EXPORTED_PROCEDURE | EXPORTED_FUNCTION | EXPORTED_ENTRY_POINT | EXPORTED_TYPE | EXPORTED_OBJECT | EXPORTED_EXCEPTION | CONNECTION_BY_CALL | CONNECTION_FOR_DATA => CALL_VARIETY : CALL_CONNECTION_TYPE := NO_CONNECTION; CONNECTEE : TREE_NODE_ACCESS_TYPE := NULL_POINTER ; LINE : LINE_TYPE := NULL_LINE ; when others => null; end case; end record; ---------------------------------------------------------------------- -- The arrays containing GRAPH, LIST, and TREE nodes. ---------------------------------------------------------------------- type GRAPH_ARRAY is array (GRAPH_NODE_ACCESS_TYPE range <>) of GRAPH_NODE_TYPE; type LIST_ARRAY is array (LIST_NODE_ACCESS_TYPE range <>) of LIST_NODE_TYPE; type TREE_ARRAY is array (TREE_NODE_ACCESS_TYPE range <>) of TREE_NODE_TYPE; type PROLOGUE_ARRAY is array (PROLOGUE_NODE_ACCESS_TYPE range <>) of PROLOGUE_NODE_TYPE; ---------------------------------------------------------------------- -- The size of the arrays ---------------------------------------------------------------------- MAX_GRAPH_NODES : constant GRAPH_NODE_ACCESS_TYPE := 199; MAX_LIST_NODES : constant LIST_NODE_ACCESS_TYPE := 199; MAX_TREE_NODES : constant TREE_NODE_ACCESS_TYPE := 99; MAX_PROLOGUE_NODES : constant PROLOGUE_NODE_ACCESS_TYPE := 99; ---------------------------------------------------------------------- -- The Primary array declarations ---------------------------------------------------------------------- GRAPH : GRAPH_ARRAY (1..MAX_GRAPH_NODES); LIST : LIST_ARRAY (1..MAX_LIST_NODES); TREE : TREE_ARRAY (1..MAX_TREE_NODES); PROLOGUE : PROLOGUE_ARRAY (1..MAX_PROLOGUE_NODES); ---------------------------------------------------------------------- -- Array containing the list of enclosed entities ---------------------------------------------------------------------- type ENCLOSED_ENTITIES_TYPE is array ( 1..MAX_LIST_NODES ) of LIST_NODE_ACCESS_TYPE ; ---------------------------------------------------------------------- -- The Archive array declarations (used for recovery from -- aborted operations). ---------------------------------------------------------------------- ARCHIVE_GRAPH : GRAPH_ARRAY (1..MAX_GRAPH_NODES); ARCHIVE_LIST : LIST_ARRAY (1..MAX_LIST_NODES); ARCHIVE_TREE : TREE_ARRAY (1..MAX_TREE_NODES); ARCHIVE_PROLOGUE : PROLOGUE_ARRAY (1..MAX_PROLOGUE_NODES); ---------------------------------------------------------------------- -- The Root Node of the TREE ---------------------------------------------------------------------- ROOT_NODE : constant TREE_NODE_ACCESS_TYPE := TREE'first ; end TREE_DATA; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --tree_data_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-08-06 1540 by JL package body TREE_DATA is begin -- initialize the root of the tree. TREE(ROOT_NODE) := (ROOT, -- NODE_TYPE NULL_NAME, -- NAME NULL_POINTER, -- PARENT NULL_POINTER, -- GRAPH_DATA NULL_POINTER, -- MEMBERSHIP NULL_POINTER); -- CONTAINED_ENTITY_LIST end TREE_DATA; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --terminal_access_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- VERSION 85-11-06 14:15 by JNB with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; package TERMINAL_ACCESS is -- ================================================================== -- This package implements a version of the Graphical -- Kernel System (GKS) developed by SYSCON Corporation -- for use to the target terminal type. -- Calls to this package will originate only from package GKS. -- The only calls originating from this package will be to -- the target terminal drivers. This package is the standard interface -- for all target terminal accesses. -- =================================================================== package GKS_SPEC renames GKS_SPECIFICATION ; ------------------------------- -- operations available to GKS ------------------------------- type OPERATIONS_TYPE is ( USE_BOX , USE_CIRCLE , USE_MARKER , USE_POLYGON , USE_POLYLINE , USE_POLYMARKER , USE_REG_POLYGON , USE_TEXT ) ; ------------------------------------------------------------------- -- dedicated operation to use for an object draw ------------------------------------------------------------------- subtype CIRCLE_OPERATIONS_TYPE is OPERATIONS_TYPE range USE_CIRCLE..USE_CIRCLE ; subtype FILL_AREA_OPERATIONS_TYPE is OPERATIONS_TYPE range USE_POLYGON..USE_POLYGON ; subtype POLYLINE_OPERATIONS_TYPE is OPERATIONS_TYPE range USE_POLYLINE..USE_POLYLINE ; subtype POLYMARKER_OPERATIONS_TYPE is OPERATIONS_TYPE range USE_MARKER..USE_MARKER ; subtype RECTANGLE_OPERATIONS_TYPE is OPERATIONS_TYPE range USE_BOX..USE_BOX ; subtype TEXT_OPERATIONS_TYPE is OPERATIONS_TYPE range USE_TEXT..USE_TEXT ; ----------------------------------------- -- kinds of segment operation to perform ----------------------------------------- type SEGMENT_OPERATIONS_TYPE is ( START , FINISH , DESTROY , REDRAW ) ; ---------------------------------------------------------------- -- record to congregate all parameters needed by draw procedure -- -- type OBJECT_DATA_RECORD field usage -- --------------------------------------------------------- -- | USE_ type -- -- |-------------------------------- -- | | | | |- - POLYnnn - -| -- record | B | C | M | T | G | L | M | R | -- field | O | I | A | E | O | I | A | E | -- | X | R | R | X | N | N | R | G | -- | | C | K | T | | E | K | G | -- | | L | E | | | | E | O | -- | | E | R | | | | R | N | ------------------------- - - - - - - - - - - - - - - - - -- REFERENCE_POINT | * | * | * | * | | | | * | ------------------------- - - - - - - - - - - - - - - - - -- SIZE_POINT | * | * | | | | | | * | ------------------------- - - - - - - - - - - - - - - - - -- SIDES | | | | | | | | * | ------------------------- - - - - - - - - - - - - - - - - -- SHAPE_DATA_LIST | | | | | | | * | | ------------------------- - - - - - - - - - - - - - - - - -- TEXT | | | | * | | | | | ------------------------- - - - - - - - - - - - - - - - - -- POLY_SHAPE_DATA_LIST | | | | | * | * | * | | ------------------------- - - - - - - - - - - - - - - - - type OBJECT_DATA_RECORD ( DESCRIPTION : OPERATIONS_TYPE ) is record case DESCRIPTION is -- 1 when USE_BOX | USE_CIRCLE | USE_MARKER | USE_REG_POLYGON | USE_TEXT => REFERENCE_POINT : GKS_SPEC.WC.POINT ; case DESCRIPTION is -- 2 when USE_BOX | USE_CIRCLE | USE_REG_POLYGON => SIZE_POINT : GKS_SPEC.WC.POINT ; case DESCRIPTION is -- 3 when USE_REG_POLYGON => SIDES : Natural ; when others => null ; end case ; -- DESCRIPTION 3 when USE_TEXT => TEXT : STRING ( 1..80 ) := " " & -- 20 SPACES " " & -- 20 SPACES " " & -- 20 SPACES " " ; -- 20 SPACES TEXT_LENGTH : Natural := 80 ; when others => null ; end case ; -- DESCRIPTION 2 when USE_POLYGON | USE_POLYLINE | USE_POLYMARKER => SHAPE_DATA_LIST : GKS_SPEC.WC.POINT_ARRAY ( 1..100 ) ; SHAPE_LIST_LENGTH : Natural ; when others => null ; end case ; end record ; ------------------------- -- kinds of styles to use ------------------------- type STYLES_TYPE is ( FILL_PATTERN , LINE_PATTERN , MARKER_PATTERN ) ; ------------------------------------------------------------------------- -- Record type containing character size and space attributes. ------------------------------------------------------------------------- type CHARACTER_ATTRIBUTES is record WIDTH : WC_TYPE ; HEIGHT : WC_TYPE ; SPACING : WC_TYPE ; end record ; ------------------------------------------------------------------------- -- record type to congregate all parameters needed by set style procedure ------------------------------------------------------------------------- type STYLE_RECORD ( DESCRIPTION : STYLES_TYPE ) is record case DESCRIPTION is when LINE_PATTERN => LINE : GKS_SPEC.LINE_TYPE ; when FILL_PATTERN => FILL : GKS_SPEC.INTERIOR_STYLE ; when MARKER_PATTERN => MARKER : GKS_SPEC.MARKER_TYPE ; end case ; end record ; type COLOR_OBJECTS is ( ALPHA_COLOR , ALPHA_BACKGROUND , GRAPHIC_BACKGROUND , FILL_COLOR , LINE_COLOR , MARKER_COLOR , TEXT_COLOR ) ; ------------------------------------------------------ -- dedicated color index parameter variable selectors ------------------------------------------------------ subtype FOR_ALPHA_BACKGROUND_TYPE is COLOR_OBJECTS range ALPHA_BACKGROUND..ALPHA_BACKGROUND ; subtype FOR_ALPHA_WRITING_TYPE is COLOR_OBJECTS range ALPHA_COLOR..ALPHA_COLOR ; subtype FOR_GRAPHIC_BACKGROUND_TYPE is COLOR_OBJECTS range GRAPHIC_BACKGROUND..GRAPHIC_BACKGROUND ; subtype FOR_CHARACTER_COLOR_TYPE is COLOR_OBJECTS range TEXT_COLOR..TEXT_COLOR ; subtype FOR_FILL_STYLE_COLOR_TYPE is COLOR_OBJECTS range FILL_COLOR..FILL_COLOR ; subtype FOR_LINE_STYLE_COLOR_TYPE is COLOR_OBJECTS range LINE_COLOR..LINE_COLOR ; subtype FOR_MARKERS_COLOR_TYPE is COLOR_OBJECTS range MARKER_COLOR..MARKER_COLOR ; procedure CLOSE_TERMINAL ; -- ========================================================= -- End graphics operations at terminal and cleanup. -- ========================================================= procedure DEFINE_COLOR ( INDEX : in GKS_SPEC.COLOUR_INDEX ; COLOUR : in GKS_SPEC.COLOUR_REPRESENTATION ) ; -- ========================================================= -- Define the colour to be associated with a colour index on -- Effect : Redefines the entries in the colour look up table pointed -- at by the colour index. -- ========================================================= procedure DRAW ( OBJECT_DEFINITION : in OBJECT_DATA_RECORD ) ; -- ========================================================= -- draw the object described by the object definition -- ========================================================= procedure GRAPHICS_SCREEN ( GRAPHICS_VISIBILITY : in Boolean ) ; -- ========================================================= -- Turn the graphics screen on and off. -- ========================================================= procedure INIT_TERMINAL ( TERM_TYPE : out GKS_SPECIFICATION.WS_ID ) ; -- ========================================================= -- Initialize the terminal for graphics operations. -- ========================================================= procedure MAP_WINDOW_TO_VIEWPORT ( WINDOW : in NATURAL ; UPPER_LEFT_WINDOW , LOWER_RIGHT_WINDOW , UPPER_LEFT_VIEWPORT , LOWER_RIGHT_VIEWPORT : in GKS_SPEC.WC.POINT ) ; -- ========================================================= -- Creates windows at the terminal. -- Effect : All subsequent window references will occur in the -- selected viewport. -- ========================================================= procedure MOVE_SEGMENT ( SEGMENT_ID : in GKS_SPEC.SEGMENT_NAME ; LOCATION : in GKS_SPEC.WC.POINT ) ; -- ========================================================= -- relocates segment -- Effect : Sets the reference point of the segment to new location. -- ========================================================= procedure PLACE_CURSOR ( LOCATION : in GKS_SPEC.WC.POINT ) ; -- ========================================================= -- Effect : Relocates the graphics cursor to the specified location. -- ========================================================= procedure PRINT_SCREEN ( WINDOW : in NATURAL := 0 ) ; -- ========================================================= -- Print all visible segments. -- Effect : For the specified workstation, all deferred actions are -- executed, the display surface is printed to the local -- printer attached to the terminal. -- ========================================================= procedure REDRAW_ALL_SEGMENTS; -- ========================================================= -- Redraw all visible segments stored. -- Effect : For the specified workstation, all deferred actions are -- executed, the display surface is cleared if not empty, -- and all visible segments are displayed. -- ========================================================= procedure RENAME_SEGMENT ( OLD_SEGMENT_NAME : in GKS_SPEC.SEGMENT_NAME ; NEW_SEGMENT_NAME : in GKS_SPEC.SEGMENT_NAME ) ; -- ========================================================= -- Change name of a segment -- Effect : Rename the specified segment. The old segment name -- may be reused. -- ========================================================= function REQUEST_LOCATOR ( DEVICE : in GKS_SPEC.DEVICE_NUMBER ) return GKS_SPEC.WC.POINT ; -- ========================================================= -- Request position in WC and normalization transformation number -- from a locator device -- Effect : Perform a request on the specified locator device. -- ========================================================= function REQUEST_PICK ( DEVICE : in GKS_SPEC.DEVICE_NUMBER ) return GKS_SPEC.PICK_DATA_RECORD ; -- ========================================================= -- Request segment name, pick identifier and pick status from a -- pick device -- Effect : Perform a request on the specified pick device. -- ========================================================= procedure SEGMENT_OPERATION ( SELECTION : in SEGMENT_OPERATIONS_TYPE ; SEGMENT_ID : in SEGMENT_NAME ) ; -- ========================================================= -- FINISH Segment construction finished -- Effect : Close the currently open segment. Primitives may no longer -- be added to the closed segment. -- START a segment and start constructing it -- Effect : Create a segment. Subsequent calls to output primitive -- functions will place the primitives into the currently -- open segment. -- DESTROY a segment -- Effect : Delete all copies of the specified segment stored in -- GKS. The segment name may be reused. -- REDRAW a visible segment. -- Effect : For the specified workstation, the visible segment -- is displayed. -- ========================================================= procedure SET_CHARACTER_ATTRIBUTES ( CHARACTER_SIZE : in CHARACTER_ATTRIBUTES ) ; -- ========================================================= -- Set the character attributes for graphic text output. -- Effect : The current character attributes ( height, -- width, and spacing ) are set to the specified -- values. -- ========================================================= procedure SET_COLOR_INDEX ( FIGURE : in COLOR_OBJECTS; COLOUR : in GKS_SPEC.COLOUR_INDEX ) ; -- ========================================================= -- Set the colour index for use with the figure type. -- Effect : The current figure colour index is set to the -- specified value. -- ========================================================= procedure SET_CURRENT_WINDOW ( WINDOW : in NATURAL ) ; -- ========================================================= -- Selects the current active window -- Effect : All subsequent drawing will occur in the new current -- window. -- ========================================================= procedure SET_DETECTABILITY ( SEGMENT_ID : in GKS_SPEC.SEGMENT_NAME ; DETECTABILITY : in GKS_SPEC.SEGMENT_DETECTABILITY ) ; -- ========================================================= -- Mark segment undetectable or detectable -- Effect : Set the detectability attributes of the specified segment -- to DETECTABLE or UNDETECTABLE. -- ========================================================= procedure SET_HIGHLIGHTING ( SEGMENT_ID : in GKS_SPEC.SEGMENT_NAME ; HIGHLIGHT : in GKS_SPEC.SEGMENT_HIGHLIGHTING ) ; -- ========================================================= -- Mark segment normal or highlighted -- Effect : Set the highlighting attribute to the value -- HIGHLIGHTED or NORMAL. -- ========================================================= procedure SET_SEGMENT_PRIORITY ( SEGMENT_ID : in GKS_SPEC.SEGMENT_NAME ; PRIORITY : in GKS_SPEC.SEGMENT_PRIORITY ) ; -- ========================================================= -- Set priority of a segment -- Effect : Set the priority of the specified segment to the specified -- priority. Priority is a value in the range 0 to 1. -- ========================================================= procedure SET_STYLE ( STYLE_DEFINITION : STYLE_RECORD ) ; -- ========================================================= -- Set the specified style type parameter for line, fill and marker. -- Effect : The current style type is set to the specified value. -- item Linetypes: markertypes: -- 1 - solid dot -- 2 - dashed plus sign -- 3 - dotted asterisk -- 4 - * dashed-dotted circle -- 5 - * diagonal cross -- * - implementation dependent -- ========================================================= procedure SET_TEXT_PATH ( PATH : in GKS_SPEC.TEXT_PATH ) ; -- ========================================================= -- Select the text path RIGHT, LEFT, UP, or DOWN -- Effect : Set the text path of character strings to the specified -- values for all subsequent text output primitives until -- the values are reset by another call to this function. -- ========================================================= procedure SET_TEXT_PRECISION ( PRECISION : in GKS_SPEC.TEXT_PRECISION ) ; -- ========================================================= -- Set the text precision to string, char, or stroke precision. -- Effect : Set the text precision of character strings to -- the specified value for all subsequent text -- output primitives until the values are reset by -- another call to this function. -- ========================================================= procedure SET_VISIBILITY ( SEGMENT_ID : in GKS_SPEC.SEGMENT_NAME ; VISIBILITY : in GKS_SPEC.SEGMENT_VISIBILITY ) ; -- ========================================================= -- Mark segment visible or invisible -- Effect : Set the visibility attributes of the specified segment -- to VISIBLE or INVISIBLE. -- ========================================================= -- exception conditions to be handled by user packages LOCATOR_INPUT_ERROR : exception ; end TERMINAL_ACCESS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --terminal_access_tek_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- controlled by JERRY BAKER -- VERSION 85-10-18 16:00 by JNB -- -- Target display terminal is the TEKTRONIX 4107 -- with TEKDRIVER ; use TEKDRIVER ; with MATH_LIB ; with TRACE_PKG ; use TRACE_PKG ; with TEXT_IO ; use TEXT_IO ; with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; package body TERMINAL_ACCESS is -- ====================================================== -- The package body of TERMINAL_ACCESS implements the -- -- GKS operations which compose levels 0A through 1B. -- -- -- -- Hardware Support Requirments -- -- In addition to normal graphics support the -- -- following additions are required. -- -- SEGMENTS : -- -- Open/Create Close -- -- Rename Delete -- -- DRAWING : -- -- Polylines Text -- -- Complex Fill Polygons Polymarkers -- -- ====================================================== package TERMINAL_ACCESS_MATH is new MATH_LIB( FLOAT ) ; -- coordinate transformation scale constants. WORLD_SCREEN_X : constant FLOAT := FLOAT( FLOAT( TEKDRIVER.SCREEN_X_COORDINATE_MAX ) / FLOAT( GKS_SPEC.MAX_WC )) ; WORLD_SCREEN_Y : constant FLOAT := FLOAT( FLOAT( TEKDRIVER.SCREEN_Y_COORDINATE_MAX ) / FLOAT( GKS_SPEC.MAX_WC )) ; WORLD_MEMORY_X : constant FLOAT := FLOAT( FLOAT( TEKDRIVER.TERMINAL_COORDINATE_MAX ) / FLOAT( GKS_SPEC.MAX_WC )) ; WORLD_MEMORY_Y : constant FLOAT := FLOAT( FLOAT( TEKDRIVER.TERMINAL_COORDINATE_MAX ) / FLOAT( GKS_SPEC.MAX_WC )) ; -- variables to maintain the current state of reusable parameters CURRENT_CHAR_COLOR : TEKDRIVER.COLOR_INDEX := 7 ; CURRENT_CHAR_BACKGROUND : TEKDRIVER.COLOR_INDEX := 1 ; CURRENT_DIALOG_BACKGROUND : TEKDRIVER.COLOR_INDEX := 0 ; CURRENT_GRAPHIC_BACKGROUND : TEKDRIVER.COLOR_INDEX := 0 ; -- Define the offset required to place the marker precisely -- on the displayed cursor. NEW_TEXT_LOCATION : GKS_SPEC.WC.POINT ; CURRENT_CHARACTER_HEIGHT : GKS_SPEC.WC_TYPE := 0.0 ; CURRENT_FILL_PATTERN : GKS_SPEC.INTERIOR_STYLE := GKS_SPEC.HOLLOW ; CURRENT_TEXT_PRECISION : GKS_SPEC.TEXT_PRECISION := GKS_SPEC.STROKE_PRECISION ; OPEN_SEGMENT_REQUESTED : BOOLEAN := false ; CURRENT_SEGMENT : TEKDRIVER.SEGMENT_IDENTIFIER ; CURSOR_SEGMENT : constant TEKDRIVER.SEGMENT_IDENTIFIER := 0 ; INITIAL_HIGHLIGHT_SEGMENT : constant TEKDRIVER.SEGMENT_IDENTIFIER := 20000 ; GRAPHICS_VIEW : constant TEKDRIVER.VIEW_NUMBER := 1 ; MENU_VIEW : constant TEKDRIVER.VIEW_NUMBER := 2 ; CLEAR_SURFACE_1_VIEW : constant TEKDRIVER.VIEW_NUMBER := 3 ; CLEAR_SURFACE_2_VIEW : constant TEKDRIVER.VIEW_NUMBER := 4 ; CURRENT_VIEW : TEKDRIVER.VIEW_NUMBER := MENU_VIEW ; INITIAL_HIGHLIGHT_VIEW : constant TEKDRIVER.VIEW_NUMBER := 10 ; GRAPHICS_HIGHLIGHT_VIEW : constant TEKDRIVER.VIEW_NUMBER := INITIAL_HIGHLIGHT_VIEW + GRAPHICS_VIEW ; MENU_HIGHLIGHT_VIEW : constant TEKDRIVER.VIEW_NUMBER := INITIAL_HIGHLIGHT_VIEW + MENU_VIEW ; HIGHEST_COLOR_INDEX : constant TEKDRIVER.COLOR_INDEX := 15 ; HIGHEST_DIALOG_INDEX : constant TEKDRIVER.COLOR_INDEX := 7 ; BACKGROUND_INDEX : constant TEKDRIVER.COLOR_INDEX := 0 ; HIGHLIGHT_COLOR : constant GKS_SPEC.COLOUR_REPRESENTATION := ( RED => 1.00, GREEN => 0.27, BLUE => 0.74 ); WHITE_BACKGROUND : constant GKS_SPEC.COLOUR_REPRESENTATION := ( RED => 1.00, GREEN => 1.00, BLUE => 1.00 ); -- Map the high color index values ( 8 - 15 ) into the low -- index values ( 0..7 ) COLOR_INDEX_MAPPING : array ( GKS_SPEC.COLOUR_INDEX range 8..15 ) of TEKDRIVER.COLOR_INDEX := ( 8 => 6, 9 => 5, 10 => 1, 11 => 2, 12 => 1, 13 => 3, 14 => 4, 15 => 7 ) ; COLOR_REPRESENTATION : array( TEKDRIVER.COLOR_INDEX range 0..HIGHEST_COLOR_INDEX ) of GKS_SPEC.COLOUR_REPRESENTATION := ( 0..HIGHEST_COLOR_INDEX => ( RED => 0.0, GREEN => 0.0, BLUE => 0.0 )) ; GKS_LINE_TO_TEK_LINE : constant array( GKS_SPEC.LINE_TYPE range 1..4 ) of TEKDRIVER.LINE_STYLE := ( 1 => 0, -- SOLID 2 => 4, -- DASHED 3 => 1, -- DOTTED 4 => 2 ) ; -- DASHED-DOTTED GKS_MARKER_TO_TEK_MARKER : constant array( GKS_SPEC.MARKER_TYPE range 1..5 ) of TEKDRIVER.MARKER_NUMBER := ( 1 => 0, -- DOT 2 => 2, -- PLUS SIGN 3 => 3, -- ASTERISK 4 => 4, -- CIRCLE 5 => 5 ) ; -- DIAGONAL CROSS GKS_TEXT_PATH_TO_TEK_TEXT_PATH : constant array( GKS_SPEC.TEXT_PATH ) of TEKDRIVER.CHARACTER_DIRECTION := ( GKS_SPEC.RIGHT => TEKDRIVER.RIGHT, GKS_SPEC.LEFT => TEKDRIVER.LEFT, GKS_SPEC.UP => TEKDRIVER.UP, GKS_SPEC.DOWN => TEKDRIVER.DOWN ) ; GKS_HIGHLIGHT_TO_TEK_HIGHLIGHT : constant array( GKS_SPEC.SEGMENT_HIGHLIGHTING ) of TEKDRIVER.HIGHLIGHTING := ( GKS_SPEC.NORMAL => TEKDRIVER.NOT_HIGHLIGHTED, GKS_SPEC.HIGHLIGHTED => TEKDRIVER.HIGHLIGHTED ) ; GKS_VISIBILITY_TO_TEK_VISIBILITY : constant array( GKS_SPEC.SEGMENT_VISIBILITY ) of TEKDRIVER.VISIBILITY_MODE := ( GKS_SPEC.VISIBLE => TEKDRIVER.VISIBLE, GKS_SPEC.INVISIBLE => TEKDRIVER.INVISIBLE ) ; GKS_DETECTABILITY_TO_TEK_DETECTABILITY : constant array( GKS_SPEC.SEGMENT_DETECTABILITY ) of TEKDRIVER.DETECTABILITY := ( GKS_SPEC.UNDETECTABLE => TEKDRIVER.CANNOT_BE_PICKED, GKS_SPEC.DETECTABLE => TEKDRIVER.CAN_BE_PICKED ) ; GKS_PRECISION_TO_TEK_PRECISION : constant array( GKS_SPEC.TEXT_PRECISION ) of TEKDRIVER.GRAPHTEXT_PRECISION := ( GKS_SPEC.STRING_PRECISION => TEKDRIVER.STRING_TEXT, GKS_SPEC.CHAR_PRECISION => TEKDRIVER.STROKE_TEXT, GKS_SPEC.STROKE_PRECISION => TEKDRIVER.STROKE_TEXT ) ; -- internal support functions function WORLD_TO_SCREEN ( WORLD_POINT : in GKS_SPEC.WC.POINT ) return TEKDRIVER.SCREEN_POINT is -- ============================================= -- converts the gks world coordinate point to -- a TEK screen coordinate point. -- ============================================= TEK_SCREEN_POINT : TEKDRIVER.SCREEN_POINT ; begin -- WORLD_TO_SCREEN if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.WORLD_TO_SCREEN" ) ; end if ; TEK_SCREEN_POINT.X := TEKDRIVER.SCREEN_X_COORDINATE( FLOAT( WORLD_POINT.X ) * WORLD_SCREEN_X ) ; TEK_SCREEN_POINT.Y := TEKDRIVER.SCREEN_Y_COORDINATE( FLOAT( WORLD_POINT.Y ) * WORLD_SCREEN_Y ) ; return TEK_SCREEN_POINT ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.WORLD TO SCREEN "); end if ; raise ; end WORLD_TO_SCREEN ; function WORLD_TO_MEMORY ( WORLD_POINT : in GKS_SPEC.WC.POINT ) return TEKDRIVER.TERMINAL_POINT is -- ============================================= -- converts the gks world coordinate point to -- a TEK memory coordinate point. -- ============================================= MEMORY_POINT : TEKDRIVER.TERMINAL_POINT ; begin -- WORLD_TO_MEMORY if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.WORLD_TO_MEMORY" ) ; end if ; MEMORY_POINT.X := TEKDRIVER.TERMINAL_COORDINATE( FLOAT( WORLD_POINT.X ) * WORLD_MEMORY_X ) ; MEMORY_POINT.Y := TEKDRIVER.TERMINAL_COORDINATE( FLOAT( WORLD_POINT.Y ) * WORLD_MEMORY_Y ) ; return MEMORY_POINT ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.WORLD TO MEMORY "); end if ; raise ; end WORLD_TO_MEMORY ; function WORLD_COORDINATE_TO_MEMORY ( WC_COORDINATE : in GKS_SPEC.WC_TYPE ) return TEKDRIVER.TERMINAL_COORDINATE is -- ============================================= -- converts the gks world coordinate value to -- a TEK memory coordinate value -- ============================================= MEMORY_COORDINATE : TEKDRIVER.TERMINAL_COORDINATE ; begin -- WORLD_COORDINATE_TO_MEMORY if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.WORLD_COORDINATE_TO_MEMORY" ) ; end if ; MEMORY_COORDINATE := TEKDRIVER.TERMINAL_COORDINATE( FLOAT( WC_COORDINATE ) * WORLD_MEMORY_X ) ; return MEMORY_COORDINATE ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( " EXCEPTION IN TERMACCES.WORLD_COORDINATE_TO_MEMORY "); end if ; raise ; end WORLD_COORDINATE_TO_MEMORY ; function SCREEN_TO_WORLD ( TEK_SCREEN_POINT : in TEKDRIVER.SCREEN_POINT ) return GKS_SPEC.WC.POINT is -- ============================================= -- converts the TEK screen coordinate point -- to a gks world coordinate point. -- ============================================= WORLD_POINT : GKS_SPEC.WC.POINT ; begin -- SCREEN_TO_WORLD if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SCREEN_TO_WORLD") ; end if ; WORLD_POINT.X := GKS_SPEC.WC_TYPE( FLOAT( TEK_SCREEN_POINT.X ) / WORLD_SCREEN_X ) ; WORLD_POINT.Y := GKS_SPEC.WC_TYPE( FLOAT( TEK_SCREEN_POINT.Y ) / WORLD_SCREEN_Y ) ; return WORLD_POINT ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.SCREEN TO WORLD "); end if ; raise ; end SCREEN_TO_WORLD ; function MEMORY_TO_WORLD ( MEMORY_POINT : in TEKDRIVER.TERMINAL_POINT ) return GKS_SPEC.WC.POINT is -- ============================================= -- converts the TEK memory coordinate point -- to a gks world coordinate point. -- ============================================= WORLD_POINT : GKS_SPEC.WC.POINT ; begin -- MEMORY_TO_WORLD if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.MEMORY_TO_WORLD") ; end if ; WORLD_POINT.X := GKS_SPEC.WC_TYPE( FLOAT( MEMORY_POINT.X ) / WORLD_MEMORY_X ) ; WORLD_POINT.Y := GKS_SPEC.WC_TYPE( FLOAT( MEMORY_POINT.Y ) / WORLD_MEMORY_Y ) ; return WORLD_POINT ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.MEMORY TO WORLD "); end if ; raise ; end MEMORY_TO_WORLD ; procedure INIT_TERMINAL ( TERM_TYPE : out GKS_SPECIFICATION.WS_ID ) is -- ========================================================= -- Initialize the terminal for graphics operations. -- ========================================================= WORKSTATION : constant GKS_SPECIFICATION.WS_ID := 2 ; APERTURE_WIDTH : constant TEKDRIVER.TERMINAL_COORDINATE := 0 ; SCREEN_LOWER_LEFT_CORNER : TEKDRIVER.SCREEN_POINT := ( X => TEKDRIVER.SCREEN_X_COORDINATE_MIN , Y => TEKDRIVER.SCREEN_Y_COORDINATE_MIN ) ; SCREEN_UPPER_RIGHT_CORNER : TEKDRIVER.SCREEN_POINT := ( X => TEKDRIVER.SCREEN_X_COORDINATE_MAX , Y => TEKDRIVER.SCREEN_Y_COORDINATE_MAX ) ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.INIT_TERMINAL") ; end if ; -- notify GKS of graphics device type TERM_TYPE := WORKSTATION ; -- Initialize the 4107. TEKDRIVER.TERMINAL_INITIALIZATION ; -- Set surface invisible during initialization TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; -- Define the bit planes associated with surfaces 1 & 2 TEKDRIVER.SET_SURFACE_DEFINITIONS( 3, 1, 0, 0 ) ; TEKDRIVER.SET_SURFACE_VISIBILITY( TEKDRIVER.SURFACE_1, TEKDRIVER.SURFACE_INVISIBLE ); TEKDRIVER.SET_SURFACE_VISIBILITY( TEKDRIVER.SURFACE_2, TEKDRIVER.SURFACE_INVISIBLE ); TEKDRIVER.SET_SURFACE_PRIORITIES( TEKDRIVER.SURFACE_1, TEKDRIVER.PRIORITY_2, TEKDRIVER.SURFACE_2, TEKDRIVER.PRIORITY_1, TEKDRIVER.SURFACE_3, TEKDRIVER.PRIORITY_3, TEKDRIVER.SURFACE_4, TEKDRIVER.PRIORITY_4 ); -- Define the views used to erase the screen during a print -- operation. One view is defined for each utilized surface. TEKDRIVER.SELECT_VIEW( CLEAR_SURFACE_1_VIEW ) ; TEKDRIVER.SET_VIEW_ATTRIBUTES( SURFACE_1, 0, 0 ) ; TEKDRIVER.SET_VIEWPORT( SCREEN_LOWER_LEFT_CORNER, SCREEN_UPPER_RIGHT_CORNER ) ; TEKDRIVER.SELECT_VIEW( CLEAR_SURFACE_2_VIEW ) ; TEKDRIVER.SET_VIEW_ATTRIBUTES( SURFACE_2, 0, 0 ) ; TEKDRIVER.SET_VIEWPORT( SCREEN_LOWER_LEFT_CORNER, SCREEN_UPPER_RIGHT_CORNER ) ; -- Assign the menu and graphics views to surface 1, and -- the corresponding highlight views to surface 2 TEKDRIVER.SELECT_VIEW( GRAPHICS_HIGHLIGHT_VIEW ) ; TEKDRIVER.SET_VIEW_ATTRIBUTES( SURFACE_2, 0, 0 ) ; TEKDRIVER.SELECT_VIEW( MENU_HIGHLIGHT_VIEW ) ; TEKDRIVER.SET_VIEW_ATTRIBUTES( SURFACE_2, 0, 0 ) ; TEKDRIVER.SELECT_VIEW( GRAPHICS_VIEW ) ; TEKDRIVER.SET_VIEW_ATTRIBUTES( SURFACE_1, 0, 0 ) ; TEKDRIVER.SELECT_VIEW( MENU_VIEW ) ; TEKDRIVER.SET_VIEW_ATTRIBUTES( SURFACE_1, 0, 0 ) ; TEKDRIVER.SET_ALPHA_CURSOR_INDICES( CURRENT_GRAPHIC_BACKGROUND, CURRENT_GRAPHIC_BACKGROUND ) ; -- Set the pick aperture to zero, and set the error threshold -- to display terminal failure messages. TEKDRIVER.SET_PICK_APERTURE( APERTURE_WIDTH ) ; TEKDRIVER.SET_ERROR_THRESHOLD( TEKDRIVER.DISPLAY_FAILURES ) ; -- Define the highlight color on surface 2 TEKDRIVER.SET_SURFACE_COLOR_MAP( TEKDRIVER.SURFACE_2, TEKDRIVER.COLOR_INDEX( 1 ), TEKDRIVER.COLOR_COORDINATE( HIGHLIGHT_COLOR.RED * 100.0 ) , TEKDRIVER.COLOR_COORDINATE( HIGHLIGHT_COLOR.GREEN * 100.0 ) , TEKDRIVER.COLOR_COORDINATE( HIGHLIGHT_COLOR.BLUE * 100.0) ) ; -- Set terminal mode to ANSI and place cursor on bottom of screen TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; TEKDRIVER.SEND_ESCAPE_SEQUENCE_TO_4107( "[24;1H" ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.INIT TERMINAL "); end if ; raise ; end INIT_TERMINAL; procedure CLOSE_TERMINAL is -- ========================================================= -- End graphics operations at terminal and cleanup. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.CLOSE_TERMINAL") ; end if ; TEKDRIVER.TERMINAL_TERMINATION ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.CLOSE TERMINAL "); end if ; raise ; end CLOSE_TERMINAL; procedure GRAPHICS_SCREEN ( GRAPHICS_VISIBILITY : in Boolean ) is -- ========================================================= -- Turn the graphics screen on and off. -- ========================================================= VISIBILITY : TEKDRIVER.SURFACE_VISIBILITY ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.GRAPHICS_SCREEN") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; if GRAPHICS_VISIBILITY then VISIBILITY := TEKDRIVER.SURFACE_VISIBLE ; else VISIBILITY := TEKDRIVER.SURFACE_INVISIBLE ; end if ; TEKDRIVER.SET_SURFACE_VISIBILITY( TEKDRIVER.SURFACE_1, VISIBILITY ) ; TEKDRIVER.SET_SURFACE_VISIBILITY( TEKDRIVER.SURFACE_2, VISIBILITY ) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.GRAPHICS SCREEN "); end if ; raise ; end GRAPHICS_SCREEN ; procedure DRAW ( OBJECT_DEFINITION : in OBJECT_DATA_RECORD ) is -- ========================================================= -- draw the object described by the object definition -- ========================================================= HORIZONTAL_SIDE : TEKDRIVER.TERMINAL_COORDINATE ; VERTICAL_SIDE : TEKDRIVER.TERMINAL_COORDINATE ; RADIUS : TEKDRIVER.TERMINAL_COORDINATE ; OFFSET : TEKDRIVER.TERMINAL_COORDINATE ; CENTER : TEKDRIVER.TERMINAL_POINT ; START_POINT : TEKDRIVER.TERMINAL_POINT ; STOP_POINT : TEKDRIVER.TERMINAL_POINT ; NEW_POINT : TEKDRIVER.TERMINAL_POINT ; UPPER_LEFT_PT : GKS_SPEC.WC.POINT ; LOWER_RIGHT_PT : GKS_SPEC.WC.POINT ; CURRENT_PT : GKS_SPEC.WC.POINT ; COS_45 : constant FLOAT := 0.70710 ; function MAGNITUDE ( FIRST_X , FIRST_Y , SECOND_X , SECOND_Y : in FLOAT ) return FLOAT is -- ==================================================== -- produces the MAGNITUDE from first point to the second point. -- ==================================================== A, B, C : FLOAT ; begin -- MAGNITUDE A := ABS ( FIRST_X - SECOND_X ) ; B := ABS ( FIRST_Y - SECOND_Y ) ; C := TERMINAL_ACCESS_MATH.SQRT ( A * A + B * B ) ; return C ; exception when others => raise ; end MAGNITUDE ; begin -- DRAW if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.DRAW "); TRACE_PKG.TRACE ( " OPERATION =>" & OPERATIONS_TYPE'Image(OBJECT_DEFINITION.DESCRIPTION) ) ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; TEKDRIVER.SELECT_VIEW ( TEKDRIVER.VIEW_NUMBER( CURRENT_VIEW )); case OBJECT_DEFINITION.DESCRIPTION is when USE_BOX | USE_CIRCLE | USE_MARKER | USE_REG_POLYGON | USE_TEXT => UPPER_LEFT_PT := OBJECT_DEFINITION.REFERENCE_POINT ; when USE_POLYGON | USE_POLYLINE | USE_POLYMARKER => UPPER_LEFT_PT := OBJECT_DEFINITION.SHAPE_DATA_LIST( 1 ) ; end case ; -- If no segment is currently open then set the reference point -- for the segment and open the segment. if OPEN_SEGMENT_REQUESTED then TEKDRIVER.SET_PIVOT_POINT( WORLD_TO_MEMORY( UPPER_LEFT_PT )) ; TEKDRIVER.BEGIN_SEGMENT( CURRENT_SEGMENT ) ; OPEN_SEGMENT_REQUESTED := false ; end if ; case OBJECT_DEFINITION.DESCRIPTION is when USE_BOX => LOWER_RIGHT_PT := OBJECT_DEFINITION.SIZE_POINT ; if CURRENT_FILL_PATTERN = GKS_SPEC.SOLID then TEKDRIVER.BEGIN_PANEL_BOUNDARY( WORLD_TO_MEMORY( UPPER_LEFT_PT ), TEKDRIVER.CURRENT_LINE_STYLE ) ; else TEKDRIVER.MOVE( WORLD_TO_MEMORY( UPPER_LEFT_PT )) ; end if ; CURRENT_PT.X := LOWER_RIGHT_PT.X ; CURRENT_PT.Y := UPPER_LEFT_PT.Y ; TEKDRIVER.DRAW( WORLD_TO_MEMORY( CURRENT_PT )) ; TEKDRIVER.DRAW( WORLD_TO_MEMORY( LOWER_RIGHT_PT )) ; CURRENT_PT.X := UPPER_LEFT_PT.X ; CURRENT_PT.Y := LOWER_RIGHT_PT.Y ; TEKDRIVER.DRAW( WORLD_TO_MEMORY( CURRENT_PT )) ; if CURRENT_FILL_PATTERN = GKS_SPEC.SOLID then TEKDRIVER.END_PANEL ; else TEKDRIVER.DRAW( WORLD_TO_MEMORY( UPPER_LEFT_PT )) ; end if ; when USE_CIRCLE => -- normalize points to terminal type START_POINT := WORLD_TO_MEMORY ( OBJECT_DEFINITION.REFERENCE_POINT ) ; STOP_POINT := WORLD_TO_MEMORY ( OBJECT_DEFINITION.SIZE_POINT ) ; -- get the shortest side of the box HORIZONTAL_SIDE := TEKDRIVER.TERMINAL_COORDINATE( MAGNITUDE ( FLOAT ( START_POINT.X ) , FLOAT ( STOP_POINT.Y ) , FLOAT ( STOP_POINT.X ) , FLOAT ( STOP_POINT.Y ) ) ) ; VERTICAL_SIDE := TEKDRIVER.TERMINAL_COORDINATE( MAGNITUDE ( FLOAT ( START_POINT.X ) , FLOAT ( START_POINT.Y ) , FLOAT ( START_POINT.X ) , FLOAT ( STOP_POINT.Y ) ) ) ; if HORIZONTAL_SIDE < VERTICAL_SIDE then RADIUS := HORIZONTAL_SIDE / 2 ; else RADIUS := VERTICAL_SIDE / 2 ; end if ; -- get the center point from normalized box of -- a square from reference point CENTER.X := START_POINT.X + RADIUS ; CENTER.Y := START_POINT.Y - RADIUS ; OFFSET := TEKDRIVER.TERMINAL_COORDINATE( FLOAT( RADIUS ) * COS_45 ) ; NEW_POINT.X := CENTER.X ; NEW_POINT.Y := CENTER.Y + RADIUS ; TEKDRIVER.MOVE( NEW_POINT ) ; NEW_POINT.X := CENTER.X + OFFSET ; NEW_POINT.Y := CENTER.Y + OFFSET ; TEKDRIVER.DRAW( NEW_POINT ) ; NEW_POINT.X := CENTER.X + RADIUS ; NEW_POINT.Y := CENTER.Y ; TEKDRIVER.DRAW( NEW_POINT ) ; NEW_POINT.X := CENTER.X + OFFSET ; NEW_POINT.Y := CENTER.Y - OFFSET ; TEKDRIVER.DRAW( NEW_POINT ) ; NEW_POINT.X := CENTER.X ; NEW_POINT.Y := CENTER.Y - RADIUS ; TEKDRIVER.DRAW( NEW_POINT ) ; NEW_POINT.X := CENTER.X - OFFSET ; NEW_POINT.Y := CENTER.Y - OFFSET ; TEKDRIVER.DRAW( NEW_POINT ) ; NEW_POINT.X := CENTER.X - RADIUS ; NEW_POINT.Y := CENTER.Y ; TEKDRIVER.DRAW( NEW_POINT ) ; NEW_POINT.X := CENTER.X - OFFSET ; NEW_POINT.Y := CENTER.Y + OFFSET ; TEKDRIVER.DRAW( NEW_POINT ) ; NEW_POINT.X := CENTER.X ; NEW_POINT.Y := CENTER.Y + RADIUS ; TEKDRIVER.DRAW( NEW_POINT ) ; when USE_MARKER => TEKDRIVER.DRAW_MARKER( WORLD_TO_MEMORY( OBJECT_DEFINITION.REFERENCE_POINT )) ; when USE_POLYGON => null ; when USE_POLYLINE => for COORDINATE in 1..OBJECT_DEFINITION.SHAPE_LIST_LENGTH loop NEW_POINT := WORLD_TO_MEMORY( OBJECT_DEFINITION.SHAPE_DATA_LIST( COORDINATE )) ; if COORDINATE = 1 then TEKDRIVER.MOVE( NEW_POINT ) ; else TEKDRIVER.DRAW( NEW_POINT ) ; end if ; end loop ; when USE_POLYMARKER => for COORDINATE in 1..OBJECT_DEFINITION.SHAPE_LIST_LENGTH loop TEKDRIVER.DRAW_MARKER( WORLD_TO_MEMORY( OBJECT_DEFINITION.SHAPE_DATA_LIST( COORDINATE ))) ; end loop ; when USE_REG_POLYGON => null ; -- not supported when USE_TEXT => -- If the current text precision is stroke precision -- then add the graphic text offset constant to generate -- the point defining the text location. if CURRENT_TEXT_PRECISION = GKS_SPEC.STROKE_PRECISION then NEW_TEXT_LOCATION.X := OBJECT_DEFINITION.REFERENCE_POINT.X ; NEW_TEXT_LOCATION.Y := OBJECT_DEFINITION.REFERENCE_POINT.Y - CURRENT_CHARACTER_HEIGHT ; else NEW_TEXT_LOCATION := OBJECT_DEFINITION.REFERENCE_POINT ; end if ; TEKDRIVER.MOVE( WORLD_TO_MEMORY( NEW_TEXT_LOCATION )) ; TEKDRIVER.GRAPHIC_TEXT( OBJECT_DEFINITION.TEXT( 1..OBJECT_DEFINITION.TEXT_LENGTH )) ; when others => null ; end case ; -- OBJECT_DEFINITION.DESCRIPTION -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.DRAW "); end if ; raise ; end DRAW ; procedure SET_CHARACTER_ATTRIBUTES ( CHARACTER_SIZE : in CHARACTER_ATTRIBUTES ) is -- ========================================================= -- Set the character attributes for graphic text output. -- Effect : The current character attributes ( height, -- width, and spacing ) are set to the specified -- values. -- ========================================================= begin -- SET_CHARACTER_ATTRIBUTES if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SET_CHARACTER_ATTRIBUTES") ; end if ; -- Save current character height to allow location adjustment CURRENT_CHARACTER_HEIGHT := CHARACTER_SIZE.HEIGHT ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; -- Update the graph text attributes TEKDRIVER.SET_GRAPHTEXT_SIZE( WORLD_COORDINATE_TO_MEMORY( CHARACTER_SIZE.WIDTH ), WORLD_COORDINATE_TO_MEMORY( CHARACTER_SIZE.HEIGHT ), WORLD_COORDINATE_TO_MEMORY( CHARACTER_SIZE.SPACING )) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( " EXCEPTION IN TERMACCES.SET_CHARACTER_ATTRIBUTES "); end if ; raise ; end SET_CHARACTER_ATTRIBUTES ; procedure SET_COLOR_INDEX ( FIGURE : in COLOR_OBJECTS; COLOUR : in GKS_SPEC.COLOUR_INDEX ) is -- ========================================================= -- Set the colour index for use with the figure type. -- Effect : The current figure colour index is set to the -- specified value. -- ========================================================= INDEX : TEKDRIVER.COLOR_INDEX := TEKDRIVER.COLOR_INDEX( COLOUR ) ; MAPPED_COLOUR : TEKDRIVER.COLOR_INDEX := TEKDRIVER.COLOR_INDEX( COLOUR ) ; begin -- SET_COLOR_INDEX if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SET_COLOR_INDEX") ; end if ; if INDEX > HIGHEST_COLOR_INDEX then INDEX := HIGHEST_COLOR_INDEX ; end if ; -- Set the line and text colors to the specified color -- if the color is available. if INDEX > HIGHEST_DIALOG_INDEX then MAPPED_COLOUR := COLOR_INDEX_MAPPING( COLOUR ) ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; case FIGURE is when ALPHA_COLOR => CURRENT_CHAR_COLOR := TEKDRIVER.COLOR_INDEX( COLOUR ) ; TEKDRIVER.SET_DIALOG_AREA_INDEX( CURRENT_CHAR_COLOR, 5, 0 ) ; -- CURRENT_CHAR_BACKGROUND, 0 ) ; when ALPHA_BACKGROUND => CURRENT_CHAR_BACKGROUND := TEKDRIVER.COLOR_INDEX( COLOUR ) ; TEKDRIVER.SET_DIALOG_AREA_INDEX( CURRENT_CHAR_COLOR, 5, 0 ) ; -- CURRENT_CHAR_BACKGROUND, 0 ) ; when GRAPHIC_BACKGROUND => TEKDRIVER.SET_ALPHA_CURSOR_INDICES( INDEX, INDEX ) ; TEKDRIVER.SET_SURFACE_COLOR_MAP( TEKDRIVER.SURFACE_1, INDEX, TEKDRIVER.COLOR_COORDINATE( COLOR_REPRESENTATION( INDEX ).RED * 100.0 ) , TEKDRIVER.COLOR_COORDINATE( COLOR_REPRESENTATION( INDEX ).GREEN * 100.0 ) , TEKDRIVER.COLOR_COORDINATE( COLOR_REPRESENTATION( INDEX ).BLUE * 100.0 )) ; -- ************* experiment ****************** if INDEX <= HIGHEST_DIALOG_INDEX then TEKDRIVER.SET_DIALOG_AREA_COLOR_MAP( INDEX, TEKDRIVER.COLOR_COORDINATE( COLOR_REPRESENTATION( INDEX ).RED * 100.0 ) , TEKDRIVER.COLOR_COORDINATE( COLOR_REPRESENTATION( INDEX ).GREEN * 100.0 ) , TEKDRIVER.COLOR_COORDINATE( COLOR_REPRESENTATION( INDEX ).BLUE * 100.0 )) ; end if ; when FILL_COLOR => TEKDRIVER.SELECT_FILL_PATTERN( -1 * INDEX ) ; when LINE_COLOR => TEKDRIVER.SET_LINE_INDEX( INDEX ) ; when MARKER_COLOR => TEKDRIVER.SET_TEXT_INDEX( MAPPED_COLOUR ) ; when TEXT_COLOR => TEKDRIVER.SET_TEXT_INDEX( MAPPED_COLOUR ) ; when others => null ; end case ; -- FIGURE -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.SET COLOR INDEX "); end if ; raise ; end SET_COLOR_INDEX; procedure SET_STYLE ( STYLE_DEFINITION : STYLE_RECORD ) is -- ========================================================= -- Set the specified style type parameter for line, fill and marker. -- Effect : The current style type is set to the specified value. -- item Linetypes: markertypes: -- 1 - solid dot -- 2 - dashed plus sign -- 3 - dotted asterisk -- 4 - * dashed-dotted circle -- 5 - * diagonal cross -- * - implementation dependent -- ========================================================= begin -- SET_STYLE if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SET_STYLE") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; -- general screen control case STYLE_DEFINITION.DESCRIPTION is when LINE_PATTERN => TEKDRIVER.SET_LINE_STYLE( GKS_LINE_TO_TEK_LINE( STYLE_DEFINITION.LINE )) ; when FILL_PATTERN => CURRENT_FILL_PATTERN := STYLE_DEFINITION.FILL ; when MARKER_PATTERN => TEKDRIVER.SET_MARKER_TYPE( GKS_MARKER_TO_TEK_MARKER( STYLE_DEFINITION.MARKER )) ; end case ; -- STYLE_DEFINITION.DESCRIPTION -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.SET STYLE "); end if ; raise ; end SET_STYLE ; procedure SET_TEXT_PATH ( PATH : in GKS_SPEC.TEXT_PATH ) is -- ========================================================= -- Select the text path RIGHT, LEFT, UP, or DOWN -- Effect : Set the text path of character strings to the specified -- values for all subsequent text output primitives until -- the values are reset by another call to this function. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SET_TEXT_PATH") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; TEKDRIVER.SET_CHARACTER_PATH( GKS_TEXT_PATH_TO_TEK_TEXT_PATH( PATH )) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.SET TEXT PATH "); end if ; raise ; end SET_TEXT_PATH ; procedure DEFINE_COLOR ( INDEX : in GKS_SPEC.COLOUR_INDEX ; COLOUR : in GKS_SPEC.COLOUR_REPRESENTATION ) is -- ========================================================= -- Define the colour to be associated with a colour index on -- Effect : Redefines the entries in the colour look up table pointed -- at by the colour index. -- ========================================================= TEK_COLOR: TEKDRIVER.COLOR_INDEX := TEKDRIVER.COLOR_INDEX( INDEX ) ; begin -- DEFINE_COLOR if TEK_COLOR > HIGHEST_COLOR_INDEX then TEK_COLOR := HIGHEST_COLOR_INDEX ; end if ; if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.DEFINE_COLOR") ; end if ; -- If the background color is being defined ( index = 0 ), then -- set the background color to white; -- Else save the received color specification. if TEK_COLOR = BACKGROUND_INDEX then COLOR_REPRESENTATION( BACKGROUND_INDEX ) := WHITE_BACKGROUND ; else COLOR_REPRESENTATION( TEK_COLOR ) := COLOUR ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; TEKDRIVER.SET_SURFACE_COLOR_MAP( TEKDRIVER.SURFACE_1, TEK_COLOR, TEKDRIVER.COLOR_COORDINATE( COLOUR.RED * 100.0 ) , TEKDRIVER.COLOR_COORDINATE( COLOUR.GREEN * 100.0 ), TEKDRIVER.COLOR_COORDINATE( COLOUR.BLUE * 100.0 )) ; if TEK_COLOR <= HIGHEST_DIALOG_INDEX then TEKDRIVER.SET_DIALOG_AREA_COLOR_MAP( TEK_COLOR, TEKDRIVER.COLOR_COORDINATE( COLOUR.RED * 100.0 ), TEKDRIVER.COLOR_COORDINATE( COLOUR.GREEN * 100.0 ), TEKDRIVER.COLOR_COORDINATE( COLOUR.BLUE * 100.0 )) ; end if ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.DEFINE COLOR "); end if ; raise ; end DEFINE_COLOR ; procedure PLACE_CURSOR ( LOCATION : in GKS_SPEC.WC.POINT ) is -- ========================================================= -- Effect : Relocates the graphics cursor to the specified location. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.PLACE_CURSOR") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; TEKDRIVER.SET_SEGMENT_POSITION( CURSOR_SEGMENT, WORLD_TO_MEMORY ( LOCATION ) ) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; end PLACE_CURSOR ; procedure PRINT_SCREEN ( WINDOW : in Natural := 0 ) is -- ========================================================= -- Print all visible segments. -- Effect : For the specified workstation, all deferred actions are -- executed, the display surface is printed to the local -- printer attached to the terminal. -- ========================================================= begin -- PRINT_SCREEN if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.PRINT_SCREEN ") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; -- Erase the utilized surfaces TEKDRIVER.RENEW_VIEW( CLEAR_SURFACE_1_VIEW ) ; TEKDRIVER.RENEW_VIEW( CLEAR_SURFACE_2_VIEW ) ; -- Redraw the request view TEKDRIVER.RENEW_VIEW( TEKDRIVER.VIEW_NUMBER( WINDOW )); -- Perform the print operation TEKDRIVER.SELECT_HARDCOPY_INTERFACE( TEKDRIVER.TEK_4695 ) ; -- TEKDRIVER.SET_COPY_SIZE( TEKDRIVER.SMALLER_SIZE ) ; TEKDRIVER.SET_COPY_SIZE( TEKDRIVER.DEFAULT_SIZE ) ; TEKDRIVER.SET_DIALOG_AREA_HARDCOPY_ATTRIBUTES ( TEKDRIVER.NUMBER_OF_PAGES( 1 ), TEKDRIVER.FIRST_LINE, TEKDRIVER.IGNORE_FF ) ; TEKDRIVER.HARDCOPY( TEKDRIVER.POSITIVE_HARDCOPY ) ; -- Erase the displayed view TEKDRIVER.RENEW_VIEW( CLEAR_SURFACE_1_VIEW ) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.PRINT_SCREEN "); end if ; raise ; end PRINT_SCREEN ; function REQUEST_LOCATOR ( DEVICE : in GKS_SPEC.DEVICE_NUMBER ) return GKS_SPEC.WC.POINT is -- ========================================================= -- Request position in WC and normalization transformation number -- from a locator device -- Effect : Perform a request on the specified locator device. -- ========================================================= KEY_PRESSED : CHARACTER ; CURSOR_LOCATION : TEKDRIVER.TERMINAL_POINT ; SEGMENT_NUMBER : TEKDRIVER.SEGMENT_IDENTIFIER ; PICK_ID_NUMBER : TEKDRIVER.PICK_ID_IDENTIFIER ; VALID_REPORT : BOOLEAN := false ; POSITION : GKS_SPEC.WC.POINT ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.REQUEST_LOCATOR") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; while not VALID_REPORT loop begin TEKDRIVER.ENABLE_GIN( TEKDRIVER.JOYDISK, TEKDRIVER.LOCATOR, TEKDRIVER.NUMBER_OF_GIN_EVENTS( 1 )) ; TEKDRIVER.GRAPHICS_INPUT_REPORT( KEY_PRESSED, CURSOR_LOCATION, SEGMENT_NUMBER, PICK_ID_NUMBER ) ; VALID_REPORT := true ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.REQUEST_LOCATOR" & " - INVALID LOCATOR INPUT ") ; end if ; end ; end loop ; POSITION := MEMORY_TO_WORLD ( CURSOR_LOCATION ) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; return POSITION ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.REQUEST LOCATOR "); end if ; raise ; end REQUEST_LOCATOR ; procedure SEGMENT_OPERATION ( SELECTION : in SEGMENT_OPERATIONS_TYPE ; SEGMENT_ID : in GKS_SPEC.SEGMENT_NAME ) is -- ========================================================= -- FINISH Segment construction finished -- Effect : Close the currently open segment. Primitives may no longer -- be added to the closed segment. -- START a segment and start constructing it -- Effect : Create a segment. Subsequent calls to output primitive -- functions will place the primitives into the currently -- open segment. -- DESTROY a segment -- Effect : Delete all copies of the specified segment stored in -- GKS. The segment name may be reused. -- REDRAW a visible segment. -- Effect : For the specified workstation, the visible segment -- is displayed. -- ========================================================= TERMINAL_SEGMENT : TEKDRIVER.SEGMENT_IDENTIFIER ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SEGMENT_OPERATION") ; TRACE_PKG.TRACE ( " OPERATION =>" & SEGMENT_OPERATIONS_TYPE'Image ( SELECTION ) ) ; TRACE_PKG.TRACE ( " GKS SEGMENT =>" & GKS_SPEC.SEGMENT_NAME'Image ( SEGMENT_ID ) ) ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; case SELECTION is when FINISH => TEKDRIVER.END_SEGMENT ; TEKDRIVER.SET_SEGMENT_DETECTABILITY ( CURRENT_SEGMENT, TEKDRIVER.CAN_BE_PICKED ) ; TEKDRIVER.SET_SEGMENT_DISPLAY_PRIORITY ( CURRENT_SEGMENT, TEKDRIVER.PRIORITY_NUMBER( CURRENT_SEGMENT )) ; when START => CURRENT_SEGMENT := TEKDRIVER.SEGMENT_IDENTIFIER( SEGMENT_ID ) ; OPEN_SEGMENT_REQUESTED := true ; when DESTROY => TEKDRIVER.SELECT_VIEW ( TEKDRIVER.VIEW_NUMBER( CURRENT_VIEW + INITIAL_HIGHLIGHT_VIEW )); TEKDRIVER.DELETE_SEGMENT( TEKDRIVER.SEGMENT_IDENTIFIER( TEKDRIVER.SEGMENT_IDENTIFIER( SEGMENT_ID ) + INITIAL_HIGHLIGHT_SEGMENT )) ; TEKDRIVER.SELECT_VIEW ( TEKDRIVER.VIEW_NUMBER( CURRENT_VIEW )); TEKDRIVER.DELETE_SEGMENT( TEKDRIVER.SEGMENT_IDENTIFIER( SEGMENT_ID )) ; when REDRAW => TEKDRIVER.RENEW_VIEW( GRAPHICS_VIEW ) ; when others => null ; end case ; -- SELECTION -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.SEGMENT OOPERATION "); end if ; raise ; end SEGMENT_OPERATION ; procedure MOVE_SEGMENT ( SEGMENT_ID : in GKS_SPEC.SEGMENT_NAME ; LOCATION : in GKS_SPEC.WC.POINT ) is -- ========================================================= -- relocates segment -- Effect : Sets the reference point of the segment to new location. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.MOVE-SEGMENT") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; TEKDRIVER.SET_SEGMENT_POSITION( TEKDRIVER.SEGMENT_IDENTIFIER( SEGMENT_ID ), WORLD_TO_MEMORY ( LOCATION ) ) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.MOVE SEGMENT "); end if ; raise ; end MOVE_SEGMENT ; procedure RENAME_SEGMENT ( OLD_SEGMENT_NAME : in GKS_SPEC.SEGMENT_NAME ; NEW_SEGMENT_NAME : in GKS_SPEC.SEGMENT_NAME ) is -- ========================================================= -- Change name of a segment -- Effect : Rename the specified segment. The old segment name -- may be reused. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.RENAME_SEGMENT") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; TEKDRIVER.RENAME_SEGMENT( TEKDRIVER.SEGMENT_IDENTIFIER( OLD_SEGMENT_NAME ), TEKDRIVER.SEGMENT_IDENTIFIER( NEW_SEGMENT_NAME )) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.RENAME SEGMENT ") ; end if ; raise ; end RENAME_SEGMENT ; procedure SET_HIGHLIGHTING ( SEGMENT_ID : in GKS_SPEC.SEGMENT_NAME ; HIGHLIGHT : in GKS_SPEC.SEGMENT_HIGHLIGHTING ) is -- ========================================================= -- Mark segment normal or highlighted -- Effect : Set the highlighting attribute to the value -- HIGHLIGHTED or NORMAL. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SET-HIGHLIGHTING") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; TEKDRIVER.SELECT_VIEW ( TEKDRIVER.VIEW_NUMBER( CURRENT_VIEW + INITIAL_HIGHLIGHT_VIEW )); if HIGHLIGHT = GKS_SPEC.HIGHLIGHTED then TEKDRIVER.BEGIN_SEGMENT( TEKDRIVER.SEGMENT_IDENTIFIER( TEKDRIVER.SEGMENT_IDENTIFIER( SEGMENT_ID ) + INITIAL_HIGHLIGHT_SEGMENT )) ; TEKDRIVER.INCLUDE_COPY_OF_SEGMENT( TEKDRIVER.SEGMENT_IDENTIFIER( SEGMENT_ID )) ; TEKDRIVER.END_SEGMENT ; -- Set the segment highlight to normal by deleting the segment -- containing the redraw segment else TEKDRIVER.DELETE_SEGMENT( TEKDRIVER.SEGMENT_IDENTIFIER( TEKDRIVER.SEGMENT_IDENTIFIER( SEGMENT_ID ) + INITIAL_HIGHLIGHT_SEGMENT )) ; end if ; -- TEKDRIVER.RENEW_VIEW( -- TEKDRIVER.VIEW_NUMBER( CURRENT_VIEW + INITIAL_HIGHLIGHT_VIEW )); TEKDRIVER.SELECT_VIEW ( CURRENT_VIEW ) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.SET HIGHLIGHTING "); end if ; raise ; end SET_HIGHLIGHTING; procedure SET_SEGMENT_PRIORITY ( SEGMENT_ID : in GKS_SPEC.SEGMENT_NAME ; PRIORITY : in GKS_SPEC.SEGMENT_PRIORITY ) is -- ========================================================= -- Set priority of a segment -- Effect : Set the priority of the specified segment to the specified -- priority. Priority is a value in the range 0 to 1. -- ========================================================= TEK_PRIORITY : TEKDRIVER.PRIORITY_NUMBER := 32767 * TEKDRIVER.PRIORITY_NUMBER( PRIORITY ) ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SET_SEGMENT_PRIORITY") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; TEKDRIVER.SET_SEGMENT_DISPLAY_PRIORITY( TEKDRIVER.SEGMENT_IDENTIFIER( SEGMENT_ID ), TEK_PRIORITY ) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.SET SEGMENT PRIORITY "); end if ; raise ; end SET_SEGMENT_PRIORITY ; procedure REDRAW_ALL_SEGMENTS is -- ========================================================= -- Redraw all visible segments stored. -- Effect : For the specified workstation, all deferred actions are -- executed, the display surface is cleared if not empty, -- and all visible segments are displayed. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.REDRAW_ALL_SEGMENTS") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; -- Redraw all defined views TEKDRIVER.RENEW_VIEW( GRAPHICS_VIEW ) ; TEKDRIVER.RENEW_VIEW( MENU_VIEW ) ; TEKDRIVER.RENEW_VIEW( GRAPHICS_HIGHLIGHT_VIEW ) ; TEKDRIVER.RENEW_VIEW( MENU_HIGHLIGHT_VIEW ) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.REDRAW ALL SEGMENTS "); end if ; raise ; end REDRAW_ALL_SEGMENTS ; procedure SET_TEXT_PRECISION ( PRECISION : in GKS_SPEC.TEXT_PRECISION ) is -- ========================================================= -- Set the text precision to string, char, or stroke precision. -- Effect : Set the text precision of character strings to -- the specified value for all subsequent text -- output primitives until the values are reset by -- another call to this function. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SET_TEXT_PRECISION") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; -- Set the text precision TEKDRIVER.SET_GRAPHTEXT_PRECISION( GKS_PRECISION_TO_TEK_PRECISION ( PRECISION )) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.SET_TEXT_PRECISION "); end if ; raise ; end SET_TEXT_PRECISION ; procedure SET_VISIBILITY ( SEGMENT_ID : in GKS_SPEC.SEGMENT_NAME ; VISIBILITY : in GKS_SPEC.SEGMENT_VISIBILITY ) is -- ========================================================= -- Mark segment visible or invisible -- Effect : Set the visibility attributes of the specified segment -- to VISIBLE or INVISIBLE. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SET_VISIBILITY") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; TEKDRIVER.SELECT_VIEW ( TEKDRIVER.VIEW_NUMBER( CURRENT_VIEW + INITIAL_HIGHLIGHT_VIEW )); TEKDRIVER.SET_SEGMENT_VISIBILITY( TEKDRIVER.SEGMENT_IDENTIFIER( TEKDRIVER.SEGMENT_IDENTIFIER( SEGMENT_ID ) + INITIAL_HIGHLIGHT_SEGMENT ), GKS_VISIBILITY_TO_TEK_VISIBILITY( VISIBILITY )) ; TEKDRIVER.SELECT_VIEW ( TEKDRIVER.VIEW_NUMBER( CURRENT_VIEW )); TEKDRIVER.SET_SEGMENT_VISIBILITY( TEKDRIVER.SEGMENT_IDENTIFIER( SEGMENT_ID ), GKS_VISIBILITY_TO_TEK_VISIBILITY( VISIBILITY )) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.SET VISIBILITY "); end if ; raise ; end SET_VISIBILITY ; function REQUEST_PICK ( DEVICE : in GKS_SPEC.DEVICE_NUMBER ) return GKS_SPEC.PICK_DATA_RECORD is -- ========================================================= -- Request segment name, pick identifier and pick status from a -- pick device -- Effect : Perform a request on the specified pick device. -- ========================================================= KEY_PRESSED : CHARACTER ; CURSOR_LOCATION : TEKDRIVER.TERMINAL_POINT ; SEGMENT_NUMBER : TEKDRIVER.SEGMENT_IDENTIFIER ; PICK_ID_NUMBER : TEKDRIVER.PICK_ID_IDENTIFIER ; VALID_REPORT : BOOLEAN := false ; POSITION : GKS_SPEC.WC.POINT ; PICK_RECORD : GKS_SPEC.PICK_DATA_RECORD ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.REQUEST_PICK") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; while not VALID_REPORT loop begin TEKDRIVER.ENABLE_GIN( TEKDRIVER.JOYDISK, TEKDRIVER.PICK , TEKDRIVER.NUMBER_OF_GIN_EVENTS( 1 )) ; TEKDRIVER.GRAPHICS_INPUT_REPORT( KEY_PRESSED, CURSOR_LOCATION, SEGMENT_NUMBER, PICK_ID_NUMBER ) ; VALID_REPORT := true ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.REQUEST_PICK" & " - INVALID PICK INPUT ") ; end if ; end ; end loop ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; PICK_RECORD.PICK_STATUS := GKS_SPEC.PICK_REQUEST_STATUS'( OK ) ; PICK_RECORD.PICK_SEGMENT := GKS_SPEC.SEGMENT_NAME( SEGMENT_NUMBER ) ; PICK_RECORD.OBJECT_ID := GKS_SPEC.PICK_ID( PICK_ID_NUMBER ) ; return PICK_RECORD ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.REQUEST PICK "); end if ; raise ; end REQUEST_PICK ; procedure SET_DETECTABILITY ( SEGMENT_ID : in GKS_SPEC.SEGMENT_NAME ; DETECTABILITY : in GKS_SPEC.SEGMENT_DETECTABILITY ) is -- ========================================================= -- Mark segment undetectable or detectable -- Effect : Set the detectability attributes of the specified segment -- to DETECTABLE or UNDETECTABLE. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SET_DETECTABILITY") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; TEKDRIVER.SET_SEGMENT_DETECTABILITY ( TEKDRIVER.SEGMENT_IDENTIFIER( SEGMENT_ID ), GKS_DETECTABILITY_TO_TEK_DETECTABILITY( DETECTABILITY )) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.SET DETECTABILITY "); end if ; raise ; end SET_DETECTABILITY ; procedure MAP_WINDOW_TO_VIEWPORT ( WINDOW : in NATURAL ; UPPER_LEFT_WINDOW , LOWER_RIGHT_WINDOW , UPPER_LEFT_VIEWPORT , LOWER_RIGHT_VIEWPORT : in GKS_SPEC.WC.POINT ) is -- ========================================================= -- Creates windows at the terminal. -- Effect : All subsequent window references will occur in the -- selected viewport. -- ========================================================= TEK_UPPER_LEFT : TEKDRIVER.TERMINAL_POINT ; TEK_LOWER_RIGHT : TEKDRIVER.TERMINAL_POINT ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.MAP_WINDOW_TO_VIEWPORT") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; CURRENT_VIEW := TEKDRIVER.VIEW_NUMBER( WINDOW ); TEKDRIVER.SELECT_VIEW ( INITIAL_HIGHLIGHT_VIEW + TEKDRIVER.VIEW_NUMBER( WINDOW )); TEKDRIVER.SET_WINDOW( WORLD_TO_MEMORY( UPPER_LEFT_WINDOW ), WORLD_TO_MEMORY( LOWER_RIGHT_WINDOW )) ; TEKDRIVER.SET_VIEWPORT( WORLD_TO_SCREEN( UPPER_LEFT_VIEWPORT ), WORLD_TO_SCREEN( LOWER_RIGHT_VIEWPORT )); -- Redraw all segment in the view. TEKDRIVER.RENEW_VIEW ( INITIAL_HIGHLIGHT_VIEW + TEKDRIVER.VIEW_NUMBER( WINDOW )); TEKDRIVER.SELECT_VIEW ( TEKDRIVER.VIEW_NUMBER( WINDOW )); TEKDRIVER.SET_WINDOW( WORLD_TO_MEMORY( UPPER_LEFT_WINDOW ), WORLD_TO_MEMORY( LOWER_RIGHT_WINDOW )) ; TEKDRIVER.SET_VIEWPORT( WORLD_TO_SCREEN( UPPER_LEFT_VIEWPORT ), WORLD_TO_SCREEN( LOWER_RIGHT_VIEWPORT )); -- Redraw all segment in the view. TEKDRIVER.RENEW_VIEW ( TEKDRIVER.VIEW_NUMBER( WINDOW )); -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "VIEWPORT.X = " & NATURAL'IMAGE( NATURAL( UPPER_LEFT_VIEWPORT.X ) )) ; TRACE_PKG.TRACE ( "VIEWPORT.Y = " & NATURAL'IMAGE( NATURAL( UPPER_LEFT_VIEWPORT.Y ) )) ; end if ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.MAP WINDOW TO VIEWPORT "); end if ; raise ; end MAP_WINDOW_TO_VIEWPORT ; procedure SET_CURRENT_WINDOW ( WINDOW : in NATURAL ) is -- ========================================================= -- Selects the current active window -- Effect : All subsequent drawing will occur in the new current -- window. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TERMINAL_ACCESS.SET_CURRENT_WINDOW") ; end if ; -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; CURRENT_VIEW := TEKDRIVER.VIEW_NUMBER( WINDOW ); TEKDRIVER.SELECT_VIEW ( TEKDRIVER.VIEW_NUMBER( WINDOW )); -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; -- Set the text precision as a function of the current window. If CURRENT_VIEW = GRAPHICS_VIEW then CURRENT_TEXT_PRECISION := GKS_SPEC.STROKE_PRECISION ; else -- current view is MENU_VIEW CURRENT_TEXT_PRECISION := GKS_SPEC.CHAR_PRECISION ; end if ; exception when others => if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" EXCEPTION IN TERMACCES.SET CURRENT WINDOW "); end if ; raise ; end SET_CURRENT_WINDOW ; begin -- Place TEK into graphics mode TEKDRIVER.SELECT_CODE( TEKDRIVER.TEK ) ; -- Specify the number of lines available in ansi mode TEKDRIVER.SET_DIALOG_AREA_LINES( TEKDRIVER.DIALOG_LINES'( 24 )) ; -- Place TEK into ANSI mode TEKDRIVER.SELECT_CODE( TEKDRIVER.ANSI ) ; end TERMINAL_ACCESS ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --virtual_terminal_interface_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-07-16-1530 by JL with SYSTEM ; package VIRTUAL_TERMINAL_INTERFACE is -- ================================================================== -- -- The VIRTUAL_TERMINAL_INTERFACE package provides a device -- independent set of subprograms which provide alphanumeric text -- services. The primary function of this package is to support -- alphanumeric I/O to the alphanumeric window. -- -- In particular this package will support a scroll region of two -- lines on the bottom of the terminal screen for use in prompting -- for and reading interactive text. -- -- =================================================================== --{{ Suggested pragmas to speed performance of this critical --{{ low level interface -- pragma suppress ( division_check ) ; -- pragma suppress ( overflow_check ) ; -- pragma suppress ( index_check ) ; -- pragma suppress ( range_check ) ; -- pragma suppress ( length_check ) ; ------------------------------------------------------------ -- One enumeration value for each possible keypad key value -- (including usage of the GOLD key). ------------------------------------------------------------- type KEYPAD_KEY_TYPE is ( GOLD , PF2 , PF3 , PF4 , KP7 , KP8 , KP9 , KPhypen , KP4 , KP5 , KP6 , KPcomma , KP1 , KP2 , KP3 , KP0 , KPdot , ENTER , GOLD_PF2 , GOLD_PF3 , GOLD_PF4 , GOLD_KP7 , GOLD_KP8 , GOLD_KP9 , GOLD_KPhypen , GOLD_KP4 , GOLD_KP5 , GOLD_KP6 , GOLD_KPcomma , GOLD_KP1 , GOLD_KP2 , GOLD_KP3 , GOLD_KP0 , GOLD_KPdot , GOLD_ENTER , UP_ARROW , DOWN_ARROW , LEFT_ARROW , RIGHT_ARROW ) ; ---------------------------------------------------- -- The type used to communication with from the -- graphics terminal operator . ---------------------------------------------------- subtype USER_REQUEST is STRING ( 1 .. 80 ) ; subtype USER_RESPONSE is STRING ( 1 .. 80 ) ; ------------------------------------------------------------ -- The following declarations define various terminal screen -- I/O structures. -- ROW_TYPE => screen row cursor position identifier. -- COLUMN_TYPE => screen column cursor position identifier. -- ESC => String definition of an ASCII escape. -- DEL => String definition of an ASCII delete. -- NUL => String definition of an ASCII nul. ------------------------------------------------------------ subtype ROW_TYPE is INTEGER range 1 .. 24 ; subtype COLUMN_TYPE is INTEGER range 1 .. 132 ; MAXCOL : constant COLUMN_TYPE := 80 ; MAXROW : constant ROW_TYPE := 24 ; ------------------------------------------------ -- Terminal Screen Format Operation Declarations ------------------------------------------------ type FORMAT_FUNCTION is ( CLEAR_SCREEN , CENTER_A_LINE , CLEAR_A_LINE ) ; ------------------------------------------------ -- Terminal Screen I/O Operation Declarations ------------------------------------------------ type CURSOR_ADDRESS is ( READ_NO_ADDRESS , READ_WITH_ADDRESS , WRITE_NO_ADDRESS , WRITE_WITH_ADDRESS ) ; type LOW_LEVEL_CRT_FUNCTIONS is ( SCREEN_WIDTH_80 , -- Max line characters = 80. SCREEN_WIDTH_132 , NEXT_LINE , -- Sets cursor @ begining of the next line. SCROLL_UP , -- Scrolls the page text up one line. SCROLL_DOWN , -- Scrolls the page text down one line. HOME_CURSOR , -- Places cursor @ home position. ERASE_CURSOR_TO_EOL , -- Erases from cursor position -- to end of line. ERASE_BOL_TO_CURSOR , -- Erases from begining of line -- to cursor position. ERASE_CURSOR_LINE , -- Erases all text on current line. ERASE_CURSOR_TO_EOS , -- Erases screen from cursor position -- to end of screen. ERASE_BOS_TO_CURSOR , -- Erases screen from begining of screen -- to cursor position. ERASE_CURSOR_SCREEN , -- Erases all text on current screen. BLINK_CHARS , -- Blink following characters. NEGATIVE_CHARS , -- Reverse image of following characters. CLEAR_ATTRIBUTES , -- Clear graphic attributes. ERASE_SCREEN ) ; -- Erase Entire Screen procedure LOW_LEVEL_OPERATIONS ( FORMAT_FCT : in LOW_LEVEL_CRT_FUNCTIONS ) ; -- =========================================================== -- This routine provides the operations that provide the -- screen formatting capabilities identified in the Crt_Functions -- declaration list above. -- =========================================================== procedure SCROLLING_REGION ( TOP_LINE, BOTTOM_LINE : in POSITIVE ) ; -- ============================================================= -- Defines the region of the screen used for text operations. -- ============================================================= procedure MOVE_CURSOR_UP ( ROWS : in ROW_TYPE ) ; -- ============================================================= -- Moves the alphanumeric cursor up n rows. -- ============================================================= procedure MOVE_CURSOR_DOWN ( ROWS : in ROW_TYPE ) ; -- ============================================================= -- Moves the alphanumeric cursor down n rows. -- ============================================================= procedure MOVE_CURSOR_RIGHT ( COLUMNS : in COLUMN_TYPE ) ; -- ============================================================= -- Moves the alphanumeric cursor right n columns. -- ============================================================= procedure MOVE_CURSOR_LEFT ( COLUMNS : in COLUMN_TYPE ) ; -- ============================================================= -- Moves the alphanumeric cursor left n columns. -- ============================================================= procedure MOVE_CURSOR_TO ( ROW : in ROW_TYPE ; COLUMN : in COLUMN_TYPE ) ; -- ============================================================= -- Moves the alphanumeric cursor to a specified row -- and column location. -- ============================================================= procedure VTI_INIT ; -- =========================================================== -- Initialize this version of the VIRTUAL_TERMINAL_INTERFACE -- with the terminal specific data required. -- =========================================================== procedure STRINGIO ( STRNG : in out STRING ; ADDRESS : in CURSOR_ADDRESS ; ROW : in ROW_TYPE ; COL : in COLUMN_TYPE ) ; -- ========================================================= -- This routine performs string I/O operations as per -- the specified formal parameters. -- ========================================================= procedure CHARACTERIO ( CHAR : in out CHARACTER ; ADDRESS : in CURSOR_ADDRESS ; ROW : in ROW_TYPE ; COL : in COLUMN_TYPE ) ; -- ========================================================= -- This routine performs character I/O operations as per -- the specified formal parameters. -- ========================================================= procedure INTEGERIO ( INT : in out INTEGER ; ADDRESS : in CURSOR_ADDRESS ; ROW : in ROW_TYPE ; COL : in COLUMN_TYPE ) ; -- ========================================================= -- This routine performs integer I/O operations as per -- the specified formal parameters. -- ========================================================= procedure REALIO ( REAL_NO : in out FLOAT ; ADDRESS : in CURSOR_ADDRESS ; ROW : in ROW_TYPE ; COL : in COLUMN_TYPE ) ; -- ========================================================= -- This routine performs real I/O operations as per -- the specified formal parameters. -- ========================================================= procedure FORMAT_LINE ( STRNG : in STRING ; FORMAT : in FORMAT_FUNCTION ; ROW : in ROW_TYPE ) ; -- ========================================================= -- This routine performs formatted string I/O operations -- as per the specified formal parameters. -- ========================================================= function KEY_PAD_IO return KEYPAD_KEY_TYPE ; -- =============================================================== -- This routine provides keypad Input operations. -- =============================================================== end VIRTUAL_TERMINAL_INTERFACE ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --virtual_terminal_interface_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-11-22 15:55 by JB with TRACE_PKG ; use TRACE_PKG ; with TEXT_IO ; use TEXT_IO ; package body VIRTUAL_TERMINAL_INTERFACE is --################################################################### -- -- The VIRTUAL_TERMINAL_INTERFACE package provides a device -- independent set of subprograms which provide alphanumeric text -- services. The primary function of this package is to support -- alphanumeric I/O to the alphanumeric window. -- -- In particular this package will support a scroll region of two -- lines on the bottom of the terminal screen for use in prompting -- for and reading interactive text. -- -- Provides the Envision terminal with the escape sequences for control -- and manipulation of alphanumeric text on the alpha plane. -- -- variable conventions -- within sequences parens exist for reader clairity and denote -- parameter variables to be replaced by values. -- (c) : ASCII 0 plus offset (characters 0-9 & :,-,?) -- (n) : ASCII 0 plus offset (characters 0-9) -- (x1,y1,..,xn,yn) : coordinates, numbers seperated -- and terminated by non-alpha and -- non-numeric characters. ie "," -- (nz) : single number variable, such as r-radius or -- a-angle -- --#################################################################### package INTEGER_IO is new TEXT_IO.INTEGER_IO( INTEGER ) ; use INTEGER_IO ; package FLOAT_IO is new TEXT_IO.FLOAT_IO( FLOAT ) ; use FLOAT_IO ; ------------------------------- -- Local Declarations ------------------------------- ESC : STRING( 1..1 ) := ( 1 => ASCII.ESC ) ; ROW_ADJ : constant INTEGER := 0 ; procedure SEND_SEQUENCE ( ESC_SEQUENCE : in STRING ) is -- ======================================================= -- This routine localizes the interface with the -- package Text_IO. -- ======================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "<ESCAPE>" & ESC_SEQUENCE ) ; end if ; TEXT_IO.PUT( ESC & ESC_SEQUENCE ) ; exception -- Trap Text_IO Exceptions Here when others => null ; end SEND_SEQUENCE ; procedure LOW_LEVEL_OPERATIONS ( FORMAT_FCT : in LOW_LEVEL_CRT_FUNCTIONS ) is -- =========================================================== -- This routine provides the operations that provide the -- screen formatting capabilities identified in the Crt_Functions -- declaration list above. -- SCREEN_WIDTH_80 ESCAPE => <ESC>[?3l -- SCREEN_WIDTH_132 ESCAPE => <ESC>[?3h -- NEXT_LINE ESCAPE => <ESC>E -- SCROLL_UP ESCAPE => <ESC>[S -- SCROLL_DOWN ESCAPE => <ESC>M -- HOME_CURSOR ESCAPE => <ESC>[H -- ERASE_CURSOR_TO_EOL ESCAPE => <ESC>[K -- ERASE_BOL_TO_CURSOR ESCAPE => <ESC>[1K -- ERASE_CURSOR_LINE ESCAPE => <ESC>[2K -- ERASE_CURSOR_TO_EOS ESCAPE => <ESC>[J -- ERASE_BOS_TO_CURSOR ESCAPE => <ESC>[1J -- ERASE_CURSOR_SCREEN ESCAPE => <ESC>[2J -- BLINK_CHARS ESCAPE => <ESC>[5m -- NEGATIVE_CHARS ESCAPE => <ESC>[7m -- CLEAR_ATTRIBUTES ESCAPE => <ESC>[0m -- ERASE_SCREEN ESCAPE => <ESC>[2J -- =========================================================== begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS" ) ; end if ; case FORMAT_FCT is when SCREEN_WIDTH_80 => SEND_SEQUENCE( "[?3l" ) ; when SCREEN_WIDTH_132 => SEND_SEQUENCE( "[?3h" ) ; when NEXT_LINE => SEND_SEQUENCE( "E" ) ; when SCROLL_UP => SEND_SEQUENCE( "[1S" ) ; when SCROLL_DOWN => SEND_SEQUENCE( "M" ) ; when HOME_CURSOR => SEND_SEQUENCE( "[H" ) ; when ERASE_CURSOR_TO_EOL => SEND_SEQUENCE( "[K" ) ; when ERASE_BOL_TO_CURSOR => SEND_SEQUENCE( "[1K" ) ; when ERASE_CURSOR_LINE => SEND_SEQUENCE( "[2K" ) ; when ERASE_CURSOR_TO_EOS => SEND_SEQUENCE( "[J" ) ; when ERASE_BOS_TO_CURSOR => SEND_SEQUENCE( "[1J" ) ; when ERASE_CURSOR_SCREEN => SEND_SEQUENCE( "[2J" ) ; when BLINK_CHARS => SEND_SEQUENCE( "[5m" ) ; when NEGATIVE_CHARS => SEND_SEQUENCE( "[7m" ) ; when CLEAR_ATTRIBUTES => SEND_SEQUENCE( "[0m" ) ; when ERASE_SCREEN => SEND_SEQUENCE( "[2J" ) ; end case ; end LOW_LEVEL_OPERATIONS ; function INT_IMAGE ( INT : in NATURAL ) return STRING is -- This local funciton returns the ascii image of a -- natural number without a leading blank. LENGTH : INTEGER := INTEGER'IMAGE( INT )'LAST ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.INT_IMAGE" ) ; end if ; return INTEGER'IMAGE( INT )(2..LENGTH) ; end INT_IMAGE ; procedure POSITION_CURSOR ( COL_NO : in INTEGER ; ROW_NO : in INTEGER ) is -- =========================================================== -- This routine positions the cursor at the specified screen -- location. The subsequent output to the screen will begin -- at this location. -- =========================================================== ROW : INTEGER ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.POSITION_CURSOR" ) ; end if ; ROW := ROW_NO + ROW_ADJ ; SEND_SEQUENCE ("[" & INT_IMAGE(ROW) & ";" & INT_IMAGE(COL_NO) & "H"); end POSITION_CURSOR ; procedure SCROLLING_REGION ( TOP_LINE, BOTTOM_LINE : in POSITIVE ) is -- ============================================================= -- <ESC>[(t);(b)r -- Defines the region of the screen used for text operations. -- ============================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.SCROLLING_REGION" ) ; end if ; SEND_SEQUENCE ( "[" & INT_IMAGE( TOP_LINE ) & ";" & INT_IMAGE( BOTTOM_LINE ) & "r" ) ; end SCROLLING_REGION ; procedure MOVE_CURSOR_UP ( ROWS : in ROW_TYPE ) is -- ============================================================= -- <ESC>[P(n)A -- Moves the alphanumeric cursor up n rows. -- ============================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.MOVE_CURSOR_UP" ) ; end if ; SEND_SEQUENCE( "[P" & INT_IMAGE( ROWS ) & "A" ) ; end MOVE_CURSOR_UP ; procedure MOVE_CURSOR_DOWN ( ROWS : in ROW_TYPE ) is -- ============================================================= -- <ESC>[P(n)B -- Moves the alphanumeric cursor down n rows. -- ============================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.MOVE_CURSOR_DOWN" ) ; end if ; SEND_SEQUENCE( "[P" & INT_IMAGE( ROWS ) & "B" ) ; end MOVE_CURSOR_DOWN ; procedure MOVE_CURSOR_RIGHT ( COLUMNS : in COLUMN_TYPE ) is -- ============================================================= -- <ESC>[P(n)C -- Moves the alphanumeric cursor right n columns. -- ============================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.MOVE_CURSOR_RIGHT" ) ; end if ; SEND_SEQUENCE( "[P" & INT_IMAGE( COLUMNS ) & "C" ) ; end MOVE_CURSOR_RIGHT ; procedure MOVE_CURSOR_LEFT ( COLUMNS : in COLUMN_TYPE ) is -- ============================================================= -- <ESC>[P(n)D -- Moves the alphanumeric cursor left n columns. -- ============================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.MOVE_CURSOR_LEFT" ) ; end if ; SEND_SEQUENCE( "[P" & INT_IMAGE( COLUMNS ) & "D" ) ; end MOVE_CURSOR_LEFT ; procedure MOVE_CURSOR_TO ( ROW : in ROW_TYPE ; COLUMN : in COLUMN_TYPE ) is -- ============================================================= -- <ESC>[Pl;PcH Pl=row Pc=column -- Moves the alphanumeric cursor to a specified row -- and column location. -- ============================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.MOVE_CURSOR_TO" ) ; end if ; POSITION_CURSOR( COLUMN , ROW ) ; end MOVE_CURSOR_TO ; procedure VTI_INIT is -- =========================================================== -- Initialize this version of the VIRTUAL_TERMINAL_INTERFACE -- with the terminal specific data required. -- =========================================================== CMD_STR : STRING( 1 .. 4 ) ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.VTI_INIT" ) ; end if ; CMD_STR( 1 ) := ASCII.L_BRACKET ; CMD_STR( 2 ) := '?' ; CMD_STR( 3 ) := '3' ; CMD_STR( 4 ) := 'l' ; --{ Little L } SEND_SEQUENCE( CMD_STR ) ; LOW_LEVEL_OPERATIONS( LOW_LEVEL_CRT_FUNCTIONS'( ERASE_SCREEN )) ; LOW_LEVEL_OPERATIONS( LOW_LEVEL_CRT_FUNCTIONS'( HOME_CURSOR )) ; end VTI_INIT ; procedure STRINGIO ( STRNG : in out STRING ; ADDRESS : in CURSOR_ADDRESS ; ROW : in ROW_TYPE ; COL : in COLUMN_TYPE ) is -- ========================================================= -- This routine performs string I/O operations as per -- the specified formal parameters. When reading, if a -- a return must be entered when using the DEC VAX. If -- only a return is entered, then a blank string is passed. -- If the entered string is longer than the string length of -- parameter it is truncated. -- ========================================================= COUNT : NATURAL ; BIG_BUFFER : STRING (1..255) := (others => ' ') ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.STRING_IO" ) ; end if ; if ADDRESS = CURSOR_ADDRESS'( WRITE_WITH_ADDRESS ) or ADDRESS = CURSOR_ADDRESS'( READ_WITH_ADDRESS ) then POSITION_CURSOR( COL , ROW ) ; end if ; if ADDRESS = CURSOR_ADDRESS'( READ_WITH_ADDRESS ) or ADDRESS = CURSOR_ADDRESS'( READ_NO_ADDRESS ) then -- initialize Output String for INDEX in STRNG'first..STRNG'last loop STRNG( INDEX ) := ' ' ; end loop ; -- -- clear buffer of extra returns -- while END_OF_LINE and not END_OF_FILE loop -- TEXT_IO.SKIP_LINE ; -- end loop ; TEXT_IO.GET_LINE( BIG_BUFFER, COUNT ) ; if COUNT = 0 then null ; elsif COUNT < STRNG'length then STRNG (STRNG'first..STRNG'first+(COUNT-1)) := BIG_BUFFER (1..COUNT) ; else STRNG := BIG_BUFFER (1..STRNG'length) ; end if ; else TEXT_IO.PUT( STRNG ) ; end if ; end STRINGIO ; procedure CHARACTERIO ( CHAR : in out CHARACTER ; ADDRESS : in CURSOR_ADDRESS ; ROW : in ROW_TYPE ; COL : in COLUMN_TYPE ) is -- ========================================================= -- This routine performs character I/O operations as per -- the specified formal parameters. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.CHARACTERIO" ) ; end if ; if ADDRESS = CURSOR_ADDRESS'( WRITE_WITH_ADDRESS ) or ADDRESS = CURSOR_ADDRESS'( READ_WITH_ADDRESS ) then POSITION_CURSOR( COL , ROW ) ; end if ; if ADDRESS = CURSOR_ADDRESS'( READ_WITH_ADDRESS ) or ADDRESS = CURSOR_ADDRESS'( READ_NO_ADDRESS ) then TEXT_IO.GET( CHAR ) ; else TEXT_IO.PUT( CHAR ) ; end if ; end CHARACTERIO ; procedure INTEGERIO ( INT : in out INTEGER ; ADDRESS : in CURSOR_ADDRESS ; ROW : in ROW_TYPE ; COL : in COLUMN_TYPE ) is -- ========================================================= -- This routine performs integer I/O operations as per -- the specified formal parameters. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.INTEGERIO" ) ; end if ; if ADDRESS = CURSOR_ADDRESS'( WRITE_WITH_ADDRESS ) or ADDRESS = CURSOR_ADDRESS'( READ_WITH_ADDRESS ) then POSITION_CURSOR( COL , ROW ) ; end if ; if ADDRESS = CURSOR_ADDRESS'( READ_WITH_ADDRESS ) or ADDRESS = CURSOR_ADDRESS'( READ_NO_ADDRESS ) then INTEGER_IO.GET( INT ) ; else INTEGER_IO.PUT( INT ) ; end if ; end INTEGERIO ; procedure REALIO ( REAL_NO : in out FLOAT ; ADDRESS : in CURSOR_ADDRESS ; ROW : in ROW_TYPE ; COL : in COLUMN_TYPE ) is -- ========================================================= -- This routine performs real I/O operations as per -- the specified formal parameters. -- ========================================================= begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.REALIO" ) ; end if ; if ADDRESS = CURSOR_ADDRESS'( WRITE_WITH_ADDRESS ) or ADDRESS = CURSOR_ADDRESS'( READ_WITH_ADDRESS ) then POSITION_CURSOR( COL , ROW ) ; end if ; if ADDRESS = CURSOR_ADDRESS'( READ_WITH_ADDRESS ) or ADDRESS = CURSOR_ADDRESS'( READ_NO_ADDRESS ) then FLOAT_IO.GET( REAL_NO ) ; else FLOAT_IO.PUT( REAL_NO ) ; end if ; end REALIO ; procedure FORMAT_LINE ( STRNG : in STRING ; FORMAT : in FORMAT_FUNCTION ; ROW : in ROW_TYPE ) is -- ========================================================= -- This routine performs formatted string I/O operations -- as per the specified formal parameters. -- ========================================================= COL_POS : COLUMN_TYPE := 1 ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE" ) ; end if ; case FORMAT is when CLEAR_SCREEN => LOW_LEVEL_OPERATIONS( LOW_LEVEL_CRT_FUNCTIONS'( ERASE_SCREEN )) ; LOW_LEVEL_OPERATIONS( LOW_LEVEL_CRT_FUNCTIONS'( HOME_CURSOR )) ; when CENTER_A_LINE => if STRNG'length > 78 then POSITION_CURSOR( COL_POS , ROW ) ; else COL_POS := ( 80 - STRNG'length )/2 ; POSITION_CURSOR( COL_POS , ROW ) ; end if ; TEXT_IO.PUT( STRNG ) ; when CLEAR_A_LINE => POSITION_CURSOR( COL_POS , ROW ) ; LOW_LEVEL_OPERATIONS ( LOW_LEVEL_CRT_FUNCTIONS'( ERASE_CURSOR_LINE )) ; end case ; end FORMAT_LINE ; function KEY_PAD_IO return KEYPAD_KEY_TYPE is -- =============================================================== -- This routine provides keypad Input operations. -- =============================================================== KEY_PAD_KEY : KEYPAD_KEY_TYPE := KEYPAD_KEY_TYPE'( ENTER ) ; WORK_CHAR : CHARACTER ; procedure READ_CHAR (CHAR: out CHARACTER; KEY: out KEYPAD_KEY_TYPE ) is -- ========================================== -- perform a noecho character read and -- decode escape key sequences as necessary -- ========================================== CHAR1, CHAR2, OUT_CHAR : CHARACTER ; CHARS : STRING (1..2) ; GOLD_CHAR : CHARACTER ; GOLD_KEY : KEYPAD_KEY_TYPE ; VALID_ESCAPE_SEQUENCE : BOOLEAN := TRUE ; begin --{ Read_Char } TEXT_IO.GET ( OUT_CHAR ) ; CHAR := OUT_CHAR ; if OUT_CHAR = ASCII.ESC then -- process a potential escape code sequence TEXT_IO.GET ( CHARS ) ; CHAR1 := CHARS ( 1 ) ; CHAR2 := CHARS ( 2 ) ; case CHAR1 is when '[' => case CHAR2 is -- when valid char, assign appropriate value to KEY when 'A' => KEY := UP_ARROW ; when 'B' => KEY := DOWN_ARROW ; when 'C' => KEY := RIGHT_ARROW ; when 'D' => KEY := LEFT_ARROW ; when others => VALID_ESCAPE_SEQUENCE := FALSE; end case; when 'O' => case CHAR2 is -- when valid char, assign appropriate value to KEY when 'l' => KEY := KPcomma; when 'm' => KEY := KPhypen; when 'n' => KEY := KPdot; when 'p' => KEY := KP0; when 'q' => KEY := KP1; when 'r' => KEY := KP2; when 's' => KEY := KP3; when 't' => KEY := KP4; when 'u' => KEY := KP5; when 'v' => KEY := KP6; when 'w' => KEY := KP7; when 'x' => KEY := KP8; when 'y' => KEY := KP9; when 'M' => KEY := ENTER; when 'P' => READ_CHAR (GOLD_CHAR,GOLD_KEY); -- this is for the 'GOLD' key if GOLD_CHAR = ASCII.NUL and GOLD_KEY in PF2..ENTER then -- legitimate gold key entered -- step thru to 'GOLD' range of KEYPAD_KEY_TYPE for I in PF2..ENTER loop GOLD_KEY := KEYPAD_KEY_TYPE'SUCC(GOLD_KEY); end loop; KEY := GOLD_KEY; else VALID_ESCAPE_SEQUENCE := FALSE; end if; when 'Q' => KEY := PF2; when 'R' => KEY := PF3; when 'S' => KEY := PF4; when others => VALID_ESCAPE_SEQUENCE := FALSE; end case; when others => VALID_ESCAPE_SEQUENCE := FALSE; end case; if VALID_ESCAPE_SEQUENCE then CHAR := ASCII.NUL; else CHAR := ASCII.ESC; end if; end if; end READ_CHAR ; begin --{ KEY_PAD_IO } if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "VIRTUAL_TERMINAL_INTERFACE.KEY_PAD_IO" ) ; end if ; READ_CHAR( WORK_CHAR , KEY_PAD_KEY ) ; return KEY_PAD_KEY ; end KEY_PAD_IO ; end VIRTUAL_TERMINAL_INTERFACE ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --tree_ops_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 11 Feb 1986 by JR => change exception decl. to rename -- version 85-11-05 14:20 by JL with TREE_DATA; use TREE_DATA; with GRAPHICS_DATA ; package TREE_OPS is -------------------------------------------------------------------------- -- Declare the operations needed to use the TREE -------------------------------------------------------------------------- ----------------------------------------------------------------------- -- These subprograms manage the indices into the arrays of GRAPH, -- LIST, and TREE nodes. The Get Node functions will return the -- index value and initialize the corresponding node to be the -- specified variant of the record. The Release Node procedures -- mark the node being released as unused (and hence available for -- reuse). ----------------------------------------------------------------------- function GET_NEW_GRAPH_NODE (OWNING_TREE: in TREE_NODE_ACCESS_TYPE) return GRAPH_NODE_ACCESS_TYPE; -- Get a new Graph Node, and set the OWNING_TREE_NODE field to -- the specified Tree Node. procedure RELEASE_GRAPH_NODE (NODE: in GRAPH_NODE_ACCESS_TYPE); -- This procedure releases the specified Graph Node. function GET_NEW_PROLOGUE_NODE (OWNING_TREE: in TREE_NODE_ACCESS_TYPE) return PROLOGUE_NODE_ACCESS_TYPE; -- Get a new PROLOGUE Node, and set the OWNING_TREE_NODE field to -- the specified Tree Node. procedure RELEASE_PROLOGUE_NODE (NODE: in PROLOGUE_NODE_ACCESS_TYPE); -- This procedure releases the specified PROLOGUE Node. function GET_NEW_LIST_NODE (ITEM: in TREE_NODE_ACCESS_TYPE) return LIST_NODE_ACCESS_TYPE; -- Get a new List Node, and set the ITEM field to the specified -- value. The ITEM pointer must not be null, as this indicates -- an used List Node. procedure RELEASE_LIST_NODE (NODE: in LIST_NODE_ACCESS_TYPE); -- This procedure releases the specified list node. function GET_NEW_TREE_NODE (NODE_TYPE: in ENTITY_TYPE) return TREE_NODE_ACCESS_TYPE; -- Initialize the NODE to the correct type and set all values -- to NULL (or the equivalent); procedure RELEASE_TREE_NODE (NODE: in TREE_NODE_ACCESS_TYPE); -- This procedure deletes the specified TREE_NODE and all of -- its children (if any). It will remove any dependencies -- which exist on this node as well. ----------------------------------------------------------------------- -- The following types and subprograms provide the mechanism -- for walking the tree. ----------------------------------------------------------------------- type WALK_STATE_TYPE is private ; procedure START_TREE_WALK (PARENT : in TREE_NODE_ACCESS_TYPE ; WALK_STATE : in out WALK_STATE_TYPE ) ; procedure TREE_WALK (WALK_STATE : in out WALK_STATE_TYPE ; NEXT_NODE : out TREE_NODE_ACCESS_TYPE ) ; -- This procedure and function are used to walk the tree which -- has the Parent as its root. The function TREE_WALK will -- return NULL_POINTER when all the children have been visited. -- The tree walk excludes the Membership list. Only one tree -- walk can be executed at a time (it is not re-entrant). ----------------------------------------------------------------------- -- The following subprograms provide operations to help -- use the tree. ----------------------------------------------------------------------- procedure SET_PARENT (CHILD : in TREE_NODE_ACCESS_TYPE; PARENT : in TREE_NODE_ACCESS_TYPE; RELATION : IN LIST_TYPE); -- Set the Parent Field of the Child Node, and Place the -- Child in the specified List of the Parent. ----------------------------------------------------------------------- -- These subprograms perform LIST manipulation functions -- and check to make sure that the LIST_NODE pointed to is -- the LIST header node (null back pointer). -- -- The subprograms will also add or remove the corresponding -- node from the MEMBERSHIP list of the TREE_NODE pointed to -- by the node(s). ----------------------------------------------------------------------- function GET_LIST_HEAD (LIST_OWNER: in TREE_NODE_ACCESS_TYPE; REQUESTED_LIST: in LIST_TYPE) return LIST_NODE_ACCESS_TYPE; -- Get the List Head for the REQUESTED_LIST of the specified -- Tree Node LIST_OWNER. This function raises a constraint -- error if the REQUESTED_LIST is not valid for the node type -- of LIST_OWNER. procedure SET_LIST_HEAD (LIST_OWNER: in TREE_NODE_ACCESS_TYPE; REQUESTED_LIST: in LIST_TYPE; NEW_LIST_HEAD: in LIST_NODE_ACCESS_TYPE); -- Set the List Head for the REQUESTED_LIST of the specificed -- Tree Node LIST_OWNER. procedure DELETE_LIST (LIST_OWNER: in TREE_NODE_ACCESS_TYPE; REQUESTED_LIST: in LIST_TYPE); -- Delete the entire REQUESTED_LIST, resulting in a NULL_POINTER -- for the LIST_HEAD. procedure ADD_NODE_TO_LIST (LIST_OWNER: in TREE_NODE_ACCESS_TYPE; REQUESTED_LIST: in LIST_TYPE; NODE_TO_BE_ADDED : in LIST_NODE_ACCESS_TYPE); -- Add the Node to the end of the current list. Start a new -- LIST if the current one is NULL. Place a reference to the -- LIST_OWNER in the MEMBERSHIP list of the ITEM of the list -- node NODE_TO_BE_ADDED. procedure REMOVE_NODE_FROM_LIST (LIST_OWNER: in TREE_NODE_ACCESS_TYPE; REQUESTED_LIST: in LIST_TYPE; NODE: in LIST_NODE_ACCESS_TYPE); -- Remove the specified node from the List. Set LIST_HEAD to NULL -- if this is the last element being removed. Remove the -- reference to the LIST_OWNER from the MEMBERSHIP list of the -- ITEM pointed to by the list node NODE. function FIND_NODE_REFERENCE (LIST_HEAD : in LIST_NODE_ACCESS_TYPE; NODE : in TREE_NODE_ACCESS_TYPE) return LIST_NODE_ACCESS_TYPE; -- Search the specified list for a reference to the specified node, -- and return the List Node with the reference. If no reference is -- found, then return a NULL_POINTER. function NEXT_LIST_TO_SCAN (SCANNED_NODE: in TREE_NODE_ACCESS_TYPE; CURRENT_LIST : in LIST_TYPE := START) return LIST_TYPE; -- Return the type of the next list to be scanned for the node -- specified. If no more lists are to be scanned, return a value -- of NULL_LIST. procedure BREAK_REFERENCE (FROM, TO: in TREE_NODE_ACCESS_TYPE) ; -- Remove the reference indication in the MEMBERSHIP_LIST of the -- TO node as being referenced by the FROM node. procedure MAKE_REFERENCE (FROM, TO: in TREE_NODE_ACCESS_TYPE) ; -- Place a reference indication in the MEMBERSHIP_LIST of the -- TO node as being referenced by the FROM node. procedure INITIALIZE_TREE ; -- intializes the tree to startup state -- including the reassigning of the root node ----------------------------------------------------------------------- -- These are the exceptions which will occur if the operations fail. ----------------------------------------------------------------------- INVALID_LIST_SPECIFIED : exception; INVALID_OPERATION_REQUESTED : exception; INVALID_NODE_SPECIFIED : exception; LIST_CORRUPTED : exception; -- invalid list pointers detected MISMATCHED_DEPENDENCIES : exception; NODE_SUPPLY_EXHAUSTED : exception renames GRAPHICS_DATA.OPERATION_ABORTED_BY_OPERATOR ; -- The renames allows a graceful handling of this exception -- which is announced directly in the allocation (GET_NEW_) procedures WALK_STACK_OVERFLOW : exception; TREE_CORRUPTED : exception; private ------------------------------------------------------------------------- -- declare the types and objects needed to keep track of -- the tree walk ------------------------------------------------------------------------- type WALK_ELEMENT_TYPE is record TREE_ID : TREE_NODE_ACCESS_TYPE; LIST_IN_PROGRESS : LIST_TYPE; NEXT_LIST_ELEMENT : LIST_NODE_ACCESS_TYPE; BODY_CHECKED : BOOLEAN; end record; STACK_SIZE : constant NATURAL := 20; type WALK_STACK_TYPE is array ( 1 .. STACK_SIZE ) of WALK_ELEMENT_TYPE ; type WALK_STATE_TYPE is record WALK_STACK : WALK_STACK_TYPE ; STACK_PTR : NATURAL := 1; end record ; end TREE_OPS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --tree_ops_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 10 February 1986 by JL => set .prior to null in set_list_head -- version 5 February 1986 by JL => added release list node to remove node -- version 4 February 1986 by JR => added error messages for node exhaust -- version 85-11-18 17:00 by JL with TRACE_PKG ; with GRAPHICS_DATA ; with GRAPHIC_DRIVER ; with VIRTUAL_TERMINAL_INTERFACE ; package body TREE_OPS is procedure DISPLAY_ERROR ( DISPLAY_STRING : in STRING ) is -- ========================================================= -- This procedure displays the received string to the -- operator, waits for an operator acknowledgement, and -- clears the displayed line. -- ========================================================= use VIRTUAL_TERMINAL_INTERFACE ; DUMMY_POINT : GRAPHICS_DATA.POINT ; BLANK_LINE : constant STRING := " " ; CONTINUE : constant STRING := " Press cursor control device to continue " ; OPERATOR_RESPONSE : STRING(1..1) ; BELL_STRING : constant String(1..1) := ( others => ASCII.BEL ) ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( " ERROR MESSAGE DISPLAYED :") ; TRACE_PKG.TRACE( DISPLAY_STRING ) ; end if ; -- ring the bell to get users attention VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BELL_STRING, FORMAT_FUNCTION'( CENTER_A_LINE ), ROW_TYPE( 24 )) ; -- clear the area surrounding the displayed error message VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FUNCTION'( CLEAR_A_LINE ), ROW_TYPE( 9 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FUNCTION'( CLEAR_A_LINE ), ROW_TYPE( 10 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FUNCTION'( CLEAR_A_LINE ), ROW_TYPE( 11 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FUNCTION'( CLEAR_A_LINE ), ROW_TYPE( 12 )) ; -- display received string and continue message VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( DISPLAY_STRING, FORMAT_FUNCTION'( CENTER_A_LINE ), ROW_TYPE( 10 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( CONTINUE, FORMAT_FUNCTION'( CENTER_A_LINE ), ROW_TYPE( 11 )) ; -- wait for operator acknowledgement -- use locator for ack DUMMY_POINT := GRAPHIC_DRIVER.GET_GRAPHICS_CURSOR_POSITION ; -- clear the messages VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FUNCTION'( CLEAR_A_LINE ), ROW_TYPE( 10 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FUNCTION'( CLEAR_A_LINE ), ROW_TYPE( 11 )) ; exception -- dont let the operator abort during display error when GRAPHICS_DATA.OPERATION_ABORTED_BY_OPERATOR => null ; -- propogate any unknown error when others => raise ; end DISPLAY_ERROR ; ------------------------------------------------------------------------- -- The following subprograms provide operations to get and -- release nodes. ------------------------------------------------------------------------- function GET_NEW_GRAPH_NODE (OWNING_TREE: in TREE_NODE_ACCESS_TYPE) return GRAPH_NODE_ACCESS_TYPE is -- Get a new Graph Node, and set the OWNING_TREE_NODE field to -- the specified Tree Node. NULL_NODE : GRAPH_NODE_TYPE ; -- all fields preset to null values PTR : GRAPH_NODE_ACCESS_TYPE := NULL_POINTER; begin -- check that OWNING_TREE is valid if OWNING_TREE < 0 or OWNING_TREE > MAX_TREE_NODES then raise INVALID_NODE_SPECIFIED; end if; -- search the GRAPH node array looking for an unused node for I in 1..MAX_GRAPH_NODES loop if GRAPH(I).OWNING_TREE_NODE = NULL_POINTER then -- found unused node PTR := I; exit; end if; end loop; if PTR = NULL_POINTER then -- no unused node available DISPLAY_ERROR (" UNABLE TO CONTINUE - Graph Node Supply Exhausted ") ; raise NODE_SUPPLY_EXHAUSTED; else -- initialize the node to null values GRAPH(PTR) := NULL_NODE ; -- set ownership of the Graph Node GRAPH(PTR).OWNING_TREE_NODE := OWNING_TREE; -- return the Graph Node found return PTR; end if; end GET_NEW_GRAPH_NODE; procedure RELEASE_GRAPH_NODE (NODE: in GRAPH_NODE_ACCESS_TYPE) is -- This procedure releases the specified Graph Node. begin -- check that NODE is valid if NODE < 0 or NODE > MAX_GRAPH_NODES then raise INVALID_NODE_SPECIFIED; else -- show the graph node as unused GRAPH(NODE).OWNING_TREE_NODE := NULL_POINTER; end if; end RELEASE_GRAPH_NODE; function GET_NEW_PROLOGUE_NODE (OWNING_TREE: in TREE_NODE_ACCESS_TYPE) return PROLOGUE_NODE_ACCESS_TYPE is -- Get a new PROLOGUE Node, and set the OWNING_TREE_NODE field to -- the specified Tree Node. NULL_NODE : PROLOGUE_NODE_TYPE ; -- all fields preset to null values PTR : PROLOGUE_NODE_ACCESS_TYPE := NULL_POINTER; begin -- check that OWNING_TREE is valid if OWNING_TREE < 0 or OWNING_TREE > MAX_TREE_NODES then raise INVALID_NODE_SPECIFIED; end if; -- search the PROLOGUE node array looking for an unused node for I in 1..MAX_PROLOGUE_NODES loop if PROLOGUE(I).OWNING_TREE_NODE = NULL_POINTER then -- found unused node PTR := I; exit; end if; end loop; if PTR = NULL_POINTER then -- no unused node available DISPLAY_ERROR (" UNABLE TO CONTINUE - Prologue Node Supply Exhausted ") ; raise NODE_SUPPLY_EXHAUSTED; else -- initialize the node to null values PROLOGUE(PTR) := NULL_NODE ; -- set ownership of the PROLOGUE Node PROLOGUE(PTR).OWNING_TREE_NODE := OWNING_TREE; -- return the PROLOGUE Node found return PTR; end if; end GET_NEW_PROLOGUE_NODE; procedure RELEASE_PROLOGUE_NODE (NODE: in PROLOGUE_NODE_ACCESS_TYPE) is -- This procedure releases the specified PROLOGUE Node. begin -- check that NODE is valid if NODE < 0 or NODE > MAX_PROLOGUE_NODES then raise INVALID_NODE_SPECIFIED; else -- show the PROLOGUE node as unused PROLOGUE(NODE).OWNING_TREE_NODE := NULL_POINTER; end if; end RELEASE_PROLOGUE_NODE; function GET_NEW_LIST_NODE (ITEM: in TREE_NODE_ACCESS_TYPE) return LIST_NODE_ACCESS_TYPE is -- Get a new List Node, and set the ITEM field to the specified -- value. The ITEM pointer must not be null, as this indicates -- an used List Node. PTR : LIST_NODE_ACCESS_TYPE := NULL_POINTER; begin -- check that ITEM is valid if ITEM < 0 or ITEM > MAX_TREE_NODES then raise INVALID_NODE_SPECIFIED; end if; -- search the LIST node array looking for an unused node for I in 1..MAX_LIST_NODES loop if LIST(I).ITEM = NULL_POINTER then -- found unused node PTR := I; exit; end if; end loop; if PTR = NULL_POINTER then -- no unused node available DISPLAY_ERROR (" UNABLE TO CONTINUE - List Node Supply Exhausted ") ; raise NODE_SUPPLY_EXHAUSTED; else -- set the Item pointed to by the List Node, thereby -- marking it as used LIST(PTR).ITEM := ITEM; -- return the List Node found return PTR; end if; end GET_NEW_LIST_NODE; procedure RELEASE_LIST_NODE (NODE: in LIST_NODE_ACCESS_TYPE) is -- This procedure releases the specified list node. PTR : LIST_NODE_ACCESS_TYPE := NULL_POINTER; begin -- check that NODE is valid if NODE < 0 or NODE > MAX_LIST_NODES then raise INVALID_NODE_SPECIFIED; else -- show the graph node as unused LIST(NODE).ITEM := NULL_POINTER; -- set the NEXT and PRIOR fields to NULL LIST(NODE).NEXT := NULL_POINTER; LIST(NODE).PRIOR := NULL_POINTER; end if; end RELEASE_LIST_NODE; function GET_NEW_TREE_NODE (NODE_TYPE: in ENTITY_TYPE) return TREE_NODE_ACCESS_TYPE is -- Initialize the NODE to the correct type and set all values -- to NULL (or the equivalent). This is accomplished by -- using nodes with the default values. PTR : TREE_NODE_ACCESS_TYPE := NULL_POINTER; begin -- check that ITEM is valid if NODE_TYPE = UNUSED or NODE_TYPE = ROOT then raise INVALID_NODE_SPECIFIED; end if; -- search the LIST node array looking for an unused node for I in 1 .. MAX_TREE_NODES loop if TREE(I).NODE_TYPE = UNUSED then -- found unused node PTR := I; exit; end if; end loop; if PTR = NULL_POINTER then -- no unused node available DISPLAY_ERROR (" UNABLE TO CONTINUE - Tree Node Supply Exhausted ") ; raise NODE_SUPPLY_EXHAUSTED; else -- initialize the TREE Node declare NULL_NODE : TREE_NODE_TYPE ( NODE_TYPE ) ; begin TREE(PTR) := NULL_NODE ; end ; return PTR; end if; end GET_NEW_TREE_NODE; procedure EXTRACT_NODE_FROM_LIST (LIST_HEAD: in out LIST_NODE_ACCESS_TYPE; NODE: in LIST_NODE_ACCESS_TYPE); ----------------------------------------------------------------------- -- A Local Utility ----------------------------------------------------------------------- procedure REMOVE_REFERENCE (FROM: in TREE_NODE_ACCESS_TYPE; REFERENCED_NODE: in TREE_NODE_ACCESS_TYPE) is -- This procedure removes a reference to a node. The -- original reference was stored in the MEMBERSHIP list -- of the REFERENCED_NODE. CHECK_LIST : LIST_TYPE; LIST_HEAD : LIST_NODE_ACCESS_TYPE; LIST_PTR : LIST_NODE_ACCESS_TYPE; NULL_TREE_NODE : TREE_NODE_TYPE; -- preset to null MEMBER : LIST_NODE_ACCESS_TYPE; NEXT_MEMBER : LIST_NODE_ACCESS_TYPE; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE (" in REMOVE_REFERENCE " & INTEGER'image(FROM) & " " & INTEGER'image(REFERENCED_NODE)); end if ; case TREE(FROM).NODE_TYPE is when ROOT .. TYPE_TASK | TYPE_BODY => -- remove the item from the list CHECK_LIST := START; loop CHECK_LIST := NEXT_LIST_TO_SCAN (FROM, CHECK_LIST); exit when CHECK_LIST = NULL_LIST; LIST_HEAD := GET_LIST_HEAD (FROM, CHECK_LIST); LIST_PTR := FIND_NODE_REFERENCE (LIST_HEAD, REFERENCED_NODE); if LIST_PTR /= NULL_POINTER then -- extract and release the list node EXTRACT_NODE_FROM_LIST (LIST_HEAD, LIST_PTR); SET_LIST_HEAD (FROM, CHECK_LIST, LIST_HEAD); RELEASE_LIST_NODE (LIST_PTR); end if; end loop; if TREE(FROM).NODE_TYPE in TYPE_VIRTUAL_PACKAGE .. TYPE_TASK then if TREE(FROM).BODY_PTR = REFERENCED_NODE then TREE(FROM).BODY_PTR := NULL_POINTER ; end if ; end if ; when EXPORTED_PROCEDURE .. EXPORTED_FUNCTION | EXPORTED_TYPE .. EXPORTED_EXCEPTION => -- remove the connection TREE(FROM).CALL_VARIETY := GRAPHICS_DATA.NO_CONNECTION; TREE(FROM).CONNECTEE := NULL_POINTER; -- release LINE graph nodes for I in 1 .. MAXIMUM_NO_LINE_SEGMENTS loop if TREE(FROM).LINE(I) /= NULL_POINTER then RELEASE_GRAPH_NODE ( TREE(FROM).LINE(I) ) ; else exit ; end if ; end loop ; TREE(FROM).LINE := NULL_LINE ; when EXPORTED_ENTRY_POINT => -- for each node to be removed, remove all references -- to the current node by processing the MEMBERSHIP list MEMBER := TREE(FROM).MEMBERSHIP; loop exit when MEMBER = NULL_POINTER; -- remove the reference REMOVE_REFERENCE (LIST(MEMBER).ITEM, FROM); -- determine the next member and release the current -- list element NEXT_MEMBER := LIST(MEMBER).NEXT; RELEASE_LIST_NODE (MEMBER); -- now process the next item in the MEMBERSHIP list MEMBER := NEXT_MEMBER; end loop; -- release LINE graph nodes for I in 1 .. MAXIMUM_NO_LINE_SEGMENTS loop if TREE(FROM).LINE(I) /= NULL_POINTER then RELEASE_GRAPH_NODE ( TREE(FROM).LINE(I) ) ; else exit ; end if ; end loop ; -- no longer anything to connect to REMOVE_REFERENCE (TREE(FROM).PARENT, FROM); RELEASE_GRAPH_NODE ( TREE(FROM).GRAPH_DATA ) ; TREE(FROM) := NULL_TREE_NODE; when CONNECTION_BY_CALL .. CONNECTION_FOR_DATA => -- release LINE graph nodes for I in 1 .. MAXIMUM_NO_LINE_SEGMENTS loop if TREE(FROM).LINE(I) /= NULL_POINTER then RELEASE_GRAPH_NODE ( TREE(FROM).LINE(I) ) ; else exit ; end if ; end loop ; -- remove list node for connection off parents list REMOVE_REFERENCE (TREE(FROM).PARENT, FROM); -- remove membership list reference in Connectee RELEASE_LIST_NODE (TREE(FROM).MEMBERSHIP); TREE(FROM) := NULL_TREE_NODE; when others => null; end case; end REMOVE_REFERENCE; procedure RELEASE_TREE_NODE (NODE: in TREE_NODE_ACCESS_TYPE) is -- This procedure deletes the specified TREE_NODE and all of -- its children (if any). It will remove any dependencies -- which exist on this node as well. MEMBER : LIST_NODE_ACCESS_TYPE; NEXT_MEMBER : LIST_NODE_ACCESS_TYPE; NULL_TREE_NODE : TREE_NODE_TYPE; -- preset to null PTR : TREE_NODE_ACCESS_TYPE := NULL_POINTER; WALK_STATE : WALK_STATE_TYPE ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE (" in RELEASE_TREE_NODE " & INTEGER'image(NODE)); end if ; -- check that NODE is valid if NODE < 0 or NODE > MAX_TREE_NODES then raise INVALID_NODE_SPECIFIED; else -- release all the children by using the Tree Walk to -- scan all lists (except the Membership List) START_TREE_WALK ( NODE, WALK_STATE ); loop TREE_WALK ( WALK_STATE, PTR ) ; exit when PTR = NULL_POINTER; -- for each node to be removed, remove all references -- to the current node by processing the MEMBERSHIP list MEMBER := TREE(PTR).MEMBERSHIP; loop exit when MEMBER = NULL_POINTER; -- remove the reference REMOVE_REFERENCE (LIST(MEMBER).ITEM, PTR); -- determine the next member and release the current -- list element NEXT_MEMBER := LIST(MEMBER).NEXT; RELEASE_LIST_NODE (MEMBER); -- now process the next item in the MEMBERSHIP list MEMBER := NEXT_MEMBER; end loop; -- release the associated Graph Node if TREE(PTR).GRAPH_DATA /= NULL_POINTER then RELEASE_GRAPH_NODE (TREE(PTR).GRAPH_DATA); end if; -- release the associated Prologue Node if TREE(PTR).NODE_TYPE in TYPE_VIRTUAL_PACKAGE .. TYPE_TASK and then TREE(PTR).PROLOGUE_PTR /= NULL_POINTER then RELEASE_PROLOGUE_NODE (TREE(PTR).PROLOGUE_PTR); end if; -- handle releases and reference removal for nodes -- with non-list type connections if TREE(PTR).NODE_TYPE in EXPORTED_PROCEDURE .. CONNECTION_FOR_DATA then -- release LINE graph nodes for I in 1 .. MAXIMUM_NO_LINE_SEGMENTS loop if TREE(PTR).LINE(I) /= NULL_POINTER then RELEASE_GRAPH_NODE ( TREE(PTR).LINE(I) ) ; else exit ; end if ; end loop ; -- remove membership list reference in Connectee BREAK_REFERENCE ( PTR, TREE(PTR).CONNECTEE ) ; end if ; -- delete the lists of the current node and mark as unused TREE(PTR) := NULL_TREE_NODE; end loop; end if; end RELEASE_TREE_NODE; ------------------------------------------------------------------------- -- The following subprograms provide operations to help -- use the tree. ------------------------------------------------------------------------- procedure SET_PARENT (CHILD : in TREE_NODE_ACCESS_TYPE; PARENT : in TREE_NODE_ACCESS_TYPE; RELATION : IN LIST_TYPE)is -- Set the Parent Field of the Child Node, and Place the -- Child in the specified List of the Parent. PTR : LIST_NODE_ACCESS_TYPE := NULL_POINTER; begin -- check that the CHILD and PARENT are valid if CHILD < 0 or CHILD > MAX_TREE_NODES or PARENT < 0 or PARENT > MAX_TREE_NODES then raise INVALID_NODE_SPECIFIED; end if; -- set the PARENT field in the CHILD TREE(CHILD).PARENT := PARENT; -- place the child in the appropriate List PTR := GET_NEW_LIST_NODE (CHILD); ADD_NODE_TO_LIST (PARENT, RELATION, PTR); end SET_PARENT; ------------------------------------------------------------------------- -- The TREE WALK operations ------------------------------------------------------------------------- procedure START_TREE_WALK (PARENT : in TREE_NODE_ACCESS_TYPE ; WALK_STATE : in out WALK_STATE_TYPE ) is -- This procedure is used to initialize a tree walk, by indicating -- that a tree walk is starting for the named parent. WALK_STACK : WALK_STACK_TYPE renames WALK_STATE.WALK_STACK ; STACK_PTR : NATURAL renames WALK_STATE.STACK_PTR ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE (" in START_TREE_WALK " & INTEGER'image(PARENT)); end if ; -- check if PARENT is valid if ( PARENT < 0 or PARENT > MAX_TREE_NODES ) and then TREE(PARENT).NODE_TYPE = UNUSED then raise INVALID_NODE_SPECIFIED; else -- initialize the WALK_STACK for walk with PARENT STACK_PTR := 1; WALK_STACK(STACK_PTR).TREE_ID := PARENT; WALK_STACK(STACK_PTR).LIST_IN_PROGRESS := NEXT_LIST_TO_SCAN (PARENT, START); WALK_STACK(STACK_PTR).NEXT_LIST_ELEMENT := NULL_POINTER; WALK_STACK(STACK_PTR).BODY_CHECKED := FALSE; end if; end START_TREE_WALK; procedure TREE_WALK (WALK_STATE : in out WALK_STATE_TYPE ; NEXT_NODE : out TREE_NODE_ACCESS_TYPE ) is -- This function can be used to walk the tree which -- has the Parent as its root. The function TREE_WALK will -- return NULL_POINTER when all the children have been visited. -- The tree walk excludes the Membership list. This function -- is NOT reentrant, because it uses a static data structure. PTR : LIST_NODE_ACCESS_TYPE; WALK_STACK : WALK_STACK_TYPE renames WALK_STATE.WALK_STACK ; STACK_PTR : NATURAL renames WALK_STATE.STACK_PTR ; VALID_BODY_PTR : BOOLEAN := FALSE; procedure PUSH_STACK (ITEM : in TREE_NODE_ACCESS_TYPE ) is begin if STACK_PTR < STACK_SIZE then STACK_PTR := STACK_PTR + 1; else raise WALK_STACK_OVERFLOW; end if; TRACE_PKG.TRACE (" push the Walk Stack " & INTEGER'image(STACK_PTR)); WALK_STACK(STACK_PTR).TREE_ID := ITEM ; WALK_STACK(STACK_PTR).LIST_IN_PROGRESS := NEXT_LIST_TO_SCAN ( ITEM, START); WALK_STACK(STACK_PTR).NEXT_LIST_ELEMENT := NULL_POINTER; WALK_STACK(STACK_PTR).BODY_CHECKED := FALSE; end PUSH_STACK ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE (" in TREE_WALK, stack_ptr = " & INTEGER'image(STACK_PTR)); end if ; -- if the Stack Pointer is zero then the walk is completed if STACK_PTR <= 0 then if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE (" Tree Walk Complete *********** "); end if ; NEXT_NODE := NULL_POINTER ; return ; end if; -- search for the next node in the Tree Walk loop -- set PTR to the Next List Element to be processed PTR := WALK_STACK(STACK_PTR).NEXT_LIST_ELEMENT; -- if NULL then must be starting up on a list -- otherwise advance to next element in LIST_IN_PROGRESS if PTR = NULL_POINTER then PTR := GET_LIST_HEAD (WALK_STACK(STACK_PTR).TREE_ID, WALK_STACK(STACK_PTR).LIST_IN_PROGRESS); end if; -- if end of LIST (PTR now Null) then advance to next LIST if PTR = NULL_POINTER then -- at end of List or Null List if WALK_STACK(STACK_PTR).LIST_IN_PROGRESS /= NULL_LIST then -- set LIST_IN_PROGRESS to next list WALK_STACK(STACK_PTR).LIST_IN_PROGRESS := NEXT_LIST_TO_SCAN (WALK_STACK(STACK_PTR).TREE_ID, WALK_STACK(STACK_PTR).LIST_IN_PROGRESS); else -- have searched all children contained in lists -- of this node, so we check the body (if one exists -- and hasn't already been checked) otherwise -- were are done with this node if not WALK_STACK(STACK_PTR).BODY_CHECKED then -- check the body WALK_STACK(STACK_PTR).BODY_CHECKED := TRUE; VALID_BODY_PTR := FALSE; begin if TREE(WALK_STACK(STACK_PTR).TREE_ID).BODY_PTR /= NULL_POINTER then VALID_BODY_PTR := TRUE; end if; exception -- in case the BODY_PTR field not defined for this Node when others => null; end; if VALID_BODY_PTR then TRACE_PKG.TRACE (" NEXT WALK NODE (BODY) => "); TRACE_PKG.TRACE (INTEGER'image(TREE (WALK_STACK(STACK_PTR).TREE_ID).BODY_PTR)); WALK_STACK(STACK_PTR).NEXT_LIST_ELEMENT := NULL_POINTER ; WALK_STACK(STACK_PTR).LIST_IN_PROGRESS := NULL_LIST ; PUSH_STACK ( TREE(WALK_STACK(STACK_PTR).TREE_ID).BODY_PTR ) ; end if; else -- we are done at this level. Pop the stack and walk -- that node. STACK_PTR := STACK_PTR - 1; -- return the next Tree Node to be examined in the Walk TRACE_PKG.TRACE (" NEXT WALK NODE => "); TRACE_PKG.TRACE (INTEGER'image(WALK_STACK(STACK_PTR+1).TREE_ID)); NEXT_NODE := WALK_STACK(STACK_PTR+1).TREE_ID ; return ; end if; end if; else -- store the Next list element now, so that is the user -- of the Tree Walk deletes the current Tree node we can -- continue the walk. WALK_STACK(STACK_PTR).NEXT_LIST_ELEMENT := LIST(PTR).NEXT; -- if the Next list element is null, then advance to the -- next list if LIST(PTR).NEXT = NULL_POINTER then WALK_STACK(STACK_PTR).LIST_IN_PROGRESS := NEXT_LIST_TO_SCAN (WALK_STACK(STACK_PTR).TREE_ID, WALK_STACK(STACK_PTR).LIST_IN_PROGRESS) ; end if ; -- check subtrees of current List element by pushing the stack PUSH_STACK ( LIST(PTR).ITEM ) ; end if; end loop; exception when others => TRACE_PKG.TRACE (" exception trapped in TREE_WALK ") ; raise ; end TREE_WALK; ---------------------------------------------------------------------- -- These subprograms perform LIST manipulation functions -- and check to make sure that the LIST_NODE pointed to is -- the LIST header node (null back pointer). -- -- The subprograms will also add or remove the corresponding -- node from the MEMBERSHIP list of the TREE_NODE pointed to -- by the node(s). ---------------------------------------------------------------------- function GET_LIST_HEAD (LIST_OWNER: in TREE_NODE_ACCESS_TYPE; REQUESTED_LIST: in LIST_TYPE) return LIST_NODE_ACCESS_TYPE is -- Get the List Head for the REQUESTED_LIST of the specified -- Tree Node LIST_OWNER. begin -- check the validity of the NODE if ( LIST_OWNER < 0 or LIST_OWNER > MAX_TREE_NODES ) and then TREE(LIST_OWNER).NODE_TYPE = UNUSED then raise INVALID_NODE_SPECIFIED; end if; case REQUESTED_LIST is when START | NULL_LIST => return NULL_POINTER; when CALLEE_LIST => return TREE(LIST_OWNER).CALLEE_LIST; when CONTAINED_LIST => return TREE(LIST_OWNER).CONTAINED_ENTITY_LIST; when DATA_CONNECT_LIST => return TREE(LIST_OWNER).DATA_CONNECT_LIST; when ENTRY_LIST => return TREE(LIST_OWNER).ENTRY_LIST; when EXPORTED_LIST => return TREE(LIST_OWNER).EXPORTED_LIST; when IMPORTED_LIST => return TREE(LIST_OWNER).IMPORTED_LIST; end case; exception when others => raise; end GET_LIST_HEAD; procedure SET_LIST_HEAD (LIST_OWNER: in TREE_NODE_ACCESS_TYPE; REQUESTED_LIST: in LIST_TYPE; NEW_LIST_HEAD: in LIST_NODE_ACCESS_TYPE) is -- Set the List Head for the REQUESTED_LIST of the specified -- Tree Node LIST_OWNER. begin -- check the validity of the NODE if ( LIST_OWNER < 0 or LIST_OWNER > MAX_TREE_NODES ) and then TREE(LIST_OWNER).NODE_TYPE = UNUSED then raise INVALID_NODE_SPECIFIED; end if; -- set the prior pointer to null if NEW_LIST_HEAD /= NULL_POINTER then LIST( NEW_LIST_HEAD ).PRIOR := NULL_POINTER ; end if ; -- set the list head case REQUESTED_LIST is when START | NULL_LIST => null; -- not real lists so no action required when CALLEE_LIST => TREE(LIST_OWNER).CALLEE_LIST := NEW_LIST_HEAD; when CONTAINED_LIST => TREE(LIST_OWNER).CONTAINED_ENTITY_LIST := NEW_LIST_HEAD; when DATA_CONNECT_LIST => TREE(LIST_OWNER).DATA_CONNECT_LIST := NEW_LIST_HEAD; when ENTRY_LIST => TREE(LIST_OWNER).ENTRY_LIST := NEW_LIST_HEAD; when EXPORTED_LIST => TREE(LIST_OWNER).EXPORTED_LIST := NEW_LIST_HEAD; when IMPORTED_LIST => TREE(LIST_OWNER).IMPORTED_LIST := NEW_LIST_HEAD; end case; exception when others => TRACE_PKG.TRACE (" error found in SET_LIST_HEAD - node type " & ENTITY_TYPE'image(TREE(LIST_OWNER).NODE_TYPE)); raise; end SET_LIST_HEAD; procedure DELETE_LIST (LIST_OWNER: in TREE_NODE_ACCESS_TYPE; REQUESTED_LIST: in LIST_TYPE) is -- Delete the entire REQUESTED_LIST, resulting in a NULL_POINTER -- for the LIST_HEAD. NEXT_PTR : LIST_NODE_ACCESS_TYPE := NULL_POINTER; PTR : LIST_NODE_ACCESS_TYPE := GET_LIST_HEAD ( LIST_OWNER , REQUESTED_LIST); begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE (" in DELETE_LIST " & INTEGER'image(LIST_OWNER) & " " & LIST_TYPE'image(REQUESTED_LIST)); end if ; -- check that list exists while PTR /= NULL_POINTER loop -- store the next pointer NEXT_PTR := LIST(PTR).NEXT; -- remove the currently pointed to node using a call to -- REMOVE_NODE_FROM_LIST so that the MEMBERSHIP links -- will be correctly handled. REMOVE_NODE_FROM_LIST (LIST_OWNER, REQUESTED_LIST, PTR); -- set PTR to the next node PTR := NEXT_PTR; end loop; end DELETE_LIST; ------------------------------------------------------------------------ -- A Local Insert ------------------------------------------------------------------------ procedure INSERT_NODE_IN_LIST (LIST_HEAD: in out LIST_NODE_ACCESS_TYPE; NODE_TO_BE_ADDED: in LIST_NODE_ACCESS_TYPE) is -- Add the Node to the end of the current list. Start a new -- LIST if the current one is NULL. PTR : LIST_NODE_ACCESS_TYPE := LIST_HEAD; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE (" in INSERT_NODE " & INTEGER'image(LIST_HEAD) & " " & INTEGER'image(NODE_TO_BE_ADDED)); end if ; -- if LIST_HEAD is NULL then start the list if PTR = NULL_POINTER then LIST_HEAD := NODE_TO_BE_ADDED; -- make sure PRIOR and NEXT pointers are NULL LIST(NODE_TO_BE_ADDED).PRIOR := NULL_POINTER; LIST(NODE_TO_BE_ADDED).NEXT := NULL_POINTER; else -- check for a valid LIST and NODE if (PTR < 0 or PTR > MAX_LIST_NODES) then raise INVALID_LIST_SPECIFIED; elsif (NODE_TO_BE_ADDED < 0 or NODE_TO_BE_ADDED > MAX_LIST_NODES) and then LIST(NODE_TO_BE_ADDED).ITEM = NULL_POINTER then raise INVALID_NODE_SPECIFIED; end if; -- find the end of the list loop -- check if end of list if LIST(PTR).NEXT = NULL_POINTER then exit; -- check for invalid list pointer elsif LIST(PTR).NEXT < 0 or LIST(PTR).NEXT > MAX_LIST_NODES then raise LIST_CORRUPTED; else -- set to the next list element PTR := LIST(PTR).NEXT; end if; end loop; -- set the NEXT pointer of the old list end element LIST(PTR).NEXT := NODE_TO_BE_ADDED; -- set the PRIOR pointer of the new list end element LIST(NODE_TO_BE_ADDED).PRIOR := PTR; end if; end INSERT_NODE_IN_LIST; procedure ADD_NODE_TO_LIST (LIST_OWNER: in TREE_NODE_ACCESS_TYPE; REQUESTED_LIST: in LIST_TYPE; NODE_TO_BE_ADDED: in LIST_NODE_ACCESS_TYPE) is -- Add the Node to the end of the current list. Start a new -- LIST if the current one is NULL. Place a reference to the -- LIST_OWNER in the MEMBERSHIP list of the ITEM of the list -- node NODE_TO_BE_ADDED. ITEM_PTR : TREE_NODE_ACCESS_TYPE; NEW_LIST_NODE : LIST_NODE_ACCESS_TYPE; PTR : LIST_NODE_ACCESS_TYPE := GET_LIST_HEAD (LIST_OWNER, REQUESTED_LIST); REF_PTR : LIST_NODE_ACCESS_TYPE; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE (" in ADD_NODE " & INTEGER'image(LIST_OWNER) & " " & LIST_TYPE'image(REQUESTED_LIST) & " " & INTEGER'image(NODE_TO_BE_ADDED)); end if ; -- Insert the node in the list specified and update the -- actual list head value in case it changed. INSERT_NODE_IN_LIST (PTR, NODE_TO_BE_ADDED); SET_LIST_HEAD (LIST_OWNER, REQUESTED_LIST, PTR); -- now add the LIST_OWNER to the MEMBERSHIP list of the -- TREE node pointed to by ITEM of NODE_TO_BE_ADDED. ITEM_PTR := LIST(NODE_TO_BE_ADDED).ITEM; if ITEM_PTR /= NULL_POINTER then PTR := TREE(ITEM_PTR).MEMBERSHIP; REF_PTR := FIND_NODE_REFERENCE (PTR, LIST_OWNER); if REF_PTR /= NULL_POINTER then -- A MEMBERSHIP reference already exists so just -- increment the reference count LIST(REF_PTR).REF_COUNT := LIST(REF_PTR).REF_COUNT + 1; else -- add a node to the list NEW_LIST_NODE := GET_NEW_LIST_NODE (LIST_OWNER); INSERT_NODE_IN_LIST (TREE(ITEM_PTR).MEMBERSHIP, NEW_LIST_NODE); LIST(NEW_LIST_NODE).REF_COUNT := 1; end if; end if; exception when others => TRACE_PKG.TRACE (" error found in ADD_NODE "); raise; end ADD_NODE_TO_LIST; ------------------------------------------------------------------------ -- A Local Extract ------------------------------------------------------------------------ procedure EXTRACT_NODE_FROM_LIST (LIST_HEAD: in out LIST_NODE_ACCESS_TYPE; NODE: in LIST_NODE_ACCESS_TYPE) is -- Extract without altering the specified node from the List. -- Set the LIST to NULL if this is the last element being removed. PTR : LIST_NODE_ACCESS_TYPE := NODE; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE (" in EXTRACT_NODE " & INTEGER'image(LIST_HEAD) & " " & INTEGER'image(NODE)); end if ; -- check for a valid NODE and LIST_HEAD if (PTR < 0 or PTR > MAX_LIST_NODES) or (LIST_HEAD < 0 or LIST_HEAD > MAX_LIST_NODES) then raise INVALID_LIST_SPECIFIED; end if; -- remove the NODE from the LIST by altering the PRIOR and NEXT -- pointers of the adjacent list elements if LIST(PTR).PRIOR /= NULL_POINTER then -- set the NEXT field to the PRIOR list element LIST(LIST(PTR).PRIOR).NEXT := LIST(PTR).NEXT; else -- Null PRIOR indicates is first member of List -- so update the value of LIST_HEAD. LIST_HEAD := LIST(PTR).NEXT; end if; if LIST(PTR).NEXT /= NULL_POINTER then -- set the PRIOR field of the NEXT list element LIST(LIST(PTR).NEXT).PRIOR := LIST(PTR).PRIOR; end if; end EXTRACT_NODE_FROM_LIST; procedure REMOVE_NODE_FROM_LIST (LIST_OWNER: in TREE_NODE_ACCESS_TYPE; REQUESTED_LIST: in LIST_TYPE; NODE: in LIST_NODE_ACCESS_TYPE) is -- Remove and releases the specified node from the List. Set the -- LIST to NULL if this is the last element being removed. Remove -- and release the reference to the LIST_OWNER from the MEMBERSHIP -- list of the ITEM pointed to by the list node NODE. LIST_HEAD : LIST_NODE_ACCESS_TYPE := GET_LIST_HEAD (LIST_OWNER, REQUESTED_LIST); ITEM_PTR : TREE_NODE_ACCESS_TYPE; PTR : LIST_NODE_ACCESS_TYPE := NODE; REF_PTR : LIST_NODE_ACCESS_TYPE; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE (" in REMOVE_NODE " & INTEGER'image(LIST_OWNER) & " " & LIST_TYPE'image(REQUESTED_LIST) & " " & INTEGER'image(NODE)); end if ; -- extract the node from the list specified and update the -- actual list head value in case it changed. EXTRACT_NODE_FROM_LIST (LIST_HEAD, NODE); SET_LIST_HEAD (LIST_OWNER, REQUESTED_LIST, LIST_HEAD); -- remove reference in MEMBERSHIP list of ITEM pointed to -- by the List Node to the LIST_OWNER. ITEM_PTR := LIST(PTR).ITEM; if ITEM_PTR /= NULL_POINTER then PTR := TREE(ITEM_PTR).MEMBERSHIP; REF_PTR := FIND_NODE_REFERENCE (PTR, LIST_OWNER); if REF_PTR /= NULL_POINTER then -- decrement the reference count if LIST(REF_PTR).REF_COUNT > 0 then LIST(REF_PTR).REF_COUNT := LIST(REF_PTR).REF_COUNT - 1; end if; -- remove the node if the reference count is zero if LIST(REF_PTR).REF_COUNT = 0 then EXTRACT_NODE_FROM_LIST (TREE(ITEM_PTR).MEMBERSHIP, REF_PTR); -- free the list node from the membership list RELEASE_LIST_NODE (REF_PTR); end if; end if; end if; -- free the list node from the requested list RELEASE_LIST_NODE( NODE ) ; end REMOVE_NODE_FROM_LIST; function FIND_NODE_REFERENCE (LIST_HEAD : in LIST_NODE_ACCESS_TYPE; NODE : in TREE_NODE_ACCESS_TYPE) return LIST_NODE_ACCESS_TYPE is -- Search the specified list for a reference to the specified node, -- and return the List Node with the reference. If no reference is -- found, then return a NULL_POINTER. PTR : LIST_NODE_ACCESS_TYPE := LIST_HEAD; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE (" in FIND_NODE " & INTEGER'image(LIST_HEAD) & " " & INTEGER'image(NODE)); end if ; -- check for an empty LIST if LIST_HEAD = NULL_POINTER then -- no reference to find return NULL_POINTER; -- check for a valid List Head elsif (PTR < 0 or PTR > MAX_LIST_NODES) then raise INVALID_LIST_SPECIFIED; end if; -- scan the list until NODE is found or the list ends loop if LIST(PTR).ITEM = NODE then return PTR; else -- check if end of list if LIST(PTR).NEXT = NULL_POINTER then -- no reference to NODE in this List return NULL_POINTER; -- check for invalid list pointer elsif LIST(PTR).NEXT <= 0 or LIST(PTR).NEXT > MAX_LIST_NODES then if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE(" corrupted list found in FIND_NODE_REF "); end if ; raise LIST_CORRUPTED; -- set to the next list element else PTR := LIST(PTR).NEXT; end if; end if; end loop; end FIND_NODE_REFERENCE; function NEXT_LIST_TO_SCAN (SCANNED_NODE: in TREE_NODE_ACCESS_TYPE; CURRENT_LIST : in LIST_TYPE := START) return LIST_TYPE is -- Return the type of the next list to be scanned for the node -- specified. If no more lists are to be scanned, return a value -- of NULL_LIST. DONE : BOOLEAN := FALSE; LIST_HEAD : LIST_NODE_ACCESS_TYPE; NEXT : LIST_TYPE := CURRENT_LIST; begin if CURRENT_LIST = NULL_LIST then -- all lists already scanned return NULL_LIST; else case TREE(SCANNED_NODE).NODE_TYPE is -- node types for which lists exist when ROOT .. TYPE_TASK | TYPE_BODY => loop NEXT := LIST_TYPE'succ(NEXT); if NEXT = NULL_LIST then return NULL_LIST; end if; begin LIST_HEAD := GET_LIST_HEAD (SCANNED_NODE, NEXT); -- a list head is defined so return the value DONE := TRUE; exception when others => -- list not defined for this node type so -- try again null; end; if DONE then return NEXT; end if; end loop; when others => return NULL_LIST; end case; end if; end NEXT_LIST_TO_SCAN; procedure BREAK_REFERENCE (FROM, TO: in TREE_NODE_ACCESS_TYPE) is -- Remove the reference indication in the MEMBERSHIP_LIST of the -- TO node as being referenced by the FROM node. NEW_LIST_NODE : LIST_NODE_ACCESS_TYPE ; PTR : LIST_NODE_ACCESS_TYPE ; REF_PTR : LIST_NODE_ACCESS_TYPE ; begin -- remove reference in MEMBERSHIP list of TO indicating it -- was referenced by FROM if FROM /= NULL_POINTER and TO /= NULL_POINTER then PTR := TREE(TO).MEMBERSHIP; REF_PTR := FIND_NODE_REFERENCE ( PTR, FROM ) ; if REF_PTR /= NULL_POINTER then -- decrement the reference count if LIST(REF_PTR).REF_COUNT > 0 then LIST(REF_PTR).REF_COUNT := LIST(REF_PTR).REF_COUNT - 1; end if; -- remove the node if the reference count is zero if LIST(REF_PTR).REF_COUNT = 0 then EXTRACT_NODE_FROM_LIST ( TREE(TO).MEMBERSHIP, REF_PTR); -- free the list node from the membership list RELEASE_LIST_NODE ( REF_PTR ) ; end if; end if; end if; end BREAK_REFERENCE ; procedure MAKE_REFERENCE (FROM, TO: in TREE_NODE_ACCESS_TYPE) is -- Place a reference indication in the MEMBERSHIP_LIST of the -- TO node as being referenced by the FROM node. NEW_LIST_NODE : LIST_NODE_ACCESS_TYPE ; PTR : LIST_NODE_ACCESS_TYPE ; REF_PTR : LIST_NODE_ACCESS_TYPE ; begin -- now add the LIST_OWNER to the MEMBERSHIP list of the -- TREE node pointed to by ITEM of NODE_TO_BE_ADDED. if TO /= NULL_POINTER and FROM /= NULL_POINTER then PTR := TREE(TO).MEMBERSHIP; REF_PTR := FIND_NODE_REFERENCE (PTR, FROM ); if REF_PTR /= NULL_POINTER then -- A MEMBERSHIP reference already exists so just -- increment the reference count LIST(REF_PTR).REF_COUNT := LIST(REF_PTR).REF_COUNT + 1; else -- add a node to the list NEW_LIST_NODE := GET_NEW_LIST_NODE ( FROM ); INSERT_NODE_IN_LIST (TREE(TO).MEMBERSHIP, NEW_LIST_NODE); LIST(NEW_LIST_NODE).REF_COUNT := 1; end if; end if; end MAKE_REFERENCE ; procedure INITIALIZE_TREE is -- initialize the tree by assigning all nodes -- to startup state NEW_TREE_NODE : TREE_NODE_TYPE ; NEW_ROOT_NODE : TREE_NODE_TYPE( ROOT ) ; NEW_GRAPH_NODE : GRAPH_NODE_TYPE ; NEW_LIST_NODE : LIST_NODE_TYPE ; NEW_PROLOGUE_NODE : PROLOGUE_NODE_TYPE ; begin TREE := (others => NEW_TREE_NODE ) ; GRAPH := (others => NEW_GRAPH_NODE ) ; LIST := (others => NEW_LIST_NODE ) ; PROLOGUE := (others => NEW_PROLOGUE_NODE ) ; TREE( ROOT_NODE ) := NEW_ROOT_NODE ; end INITIALIZE_TREE ; end TREE_OPS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --tree_io_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-09-17 09:30 by RAM with TREE_DATA; use TREE_DATA; package TREE_IO is -- This package provides all the necessary operations to -- read and write the graph tree from the graphics -- files in the host file system. -- -- This package manipulates data files which consist of copies -- of the graph tree nodes. The node types (GRAPH, TREE, -- and LIST) are stored in arrays in the package -- TREE_DATA. This TREE_IO package will -- copy the graph tree by copying the arrays to the -- specified data file. -- -- Requirements: -- 1) provide the read and write operations needed to -- maintain the graphics files. -- 2) detect corrupted data files. -- ------------------------------------------------------------------- -- parameters , types and objects for system file name development. -- maximum size of complete filename MAX_FILE_ID_SIZE : constant Natural := 43 ; -- DEC VAX VMS version 4.1 -- max size of extension MAX_EXTENSION_SIZE : constant Natural := 4 ; -- max size of file name part MAX_FILENAME_SIZE : constant Natural := MAX_FILE_ID_SIZE - MAX_EXTENSION_SIZE ; -- type for the total file name including extension subtype TOTAL_FILENAME_TYPE is String ( 1..MAX_FILE_ID_SIZE ) ; -- type to hold filenames subtype FILENAME_TYPE is String ( 1..MAX_FILENAME_SIZE ) ; -- type to hold extension names subtype EXTENSION_TYPE is String ( 1..MAX_EXTENSION_SIZE ) ; -- null filename for setting FILENAME_TYPE objects NULL_FILENAME : FILENAME_TYPE ; -- initialized to ascii nul s -- aggragate assignment in body execution -- name of default file for initialization DEFAULT_FILENAME : FILENAME_TYPE ; -- aggragate assignment in body execution -- name of tree filename default extension TREE_EXTENSION : constant EXTENSION_TYPE := ".GPH" ; -- name of file containing original data used DATA_FILENAME : FILENAME_TYPE ; -- aggragate assignment in body execution -- end of file name data ------------------------------------------------------------------- -- the graphics data file control parameters type FILE_HANDLING_TYPE is (SAVE, NO_SAVE, PANIC_SAVE); FILE_HANDLING_ON_EXIT : FILE_HANDLING_TYPE := SAVE; function COMPLETE_FILE_NAME ( FILE_NAME : FILENAME_TYPE ; EXTENSION : EXTENSION_TYPE ) return TOTAL_FILENAME_TYPE ; -- use the file name to the first space and append the extension -- to create a valid system file name. procedure READ ( FILE: in TOTAL_FILENAME_TYPE ) ; -- read the specified page into the arrays in -- the package TREE_DATA. Set all necessary -- parameters based on the values in the file -- (possibly number of nodes). procedure WRITE ( FILE: in TOTAL_FILENAME_TYPE ) ; -- Write the contents of the arrays in the -- package TREE_DATA to the specified file. INVALID_FILE_SPECIFIER : exception; FILE_OPERATION_FAILURE : exception; end TREE_IO; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --tree_io_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 27 November 1985 by JR with DIRECT_IO; with TEXT_IO; with TRACE_PKG ; with GRAPHICS_DATA; use GRAPHICS_DATA; package body TREE_IO is -- The following type is used to as the record format -- for reading and writing the tree to/from secondary -- storage. The use of variant records is not allowed, -- so each record will contain a GRAPH, LIST, and TREE -- node. If the number of nodes of each type varies, -- some space will be wasted. type DATA_RECORD_TYPE is ( NODE_RECORD, ATTRIBUTE_HEADER_RECORD ) ; type IO_NODE_TYPE( RECORD_TYPE : DATA_RECORD_TYPE := NODE_RECORD ) is record case RECORD_TYPE is when NODE_RECORD => GRAPH_NODE : GRAPH_NODE_TYPE ; LIST_NODE : LIST_NODE_TYPE ; PROLOGUE_NODE : PROLOGUE_NODE_TYPE ; TREE_NODE : TREE_NODE_TYPE ; -- the variant record -- must be last when ATTRIBUTE_HEADER_RECORD => INIT_ENTITY_COLOR : COLOR_ARRAY ; INIT_ENTITY_LINE : LINE_ARRAY ; INIT_FUNCTION_SYMBOL : INDICATOR_LENGTH_1 ; INIT_NORMAL_REFERENCE_SYMBOL : INDICATOR_LENGTH_1 ; INIT_VIRTUAL_REFERENCE_SYMBOL : INDICATOR_LENGTH_2 ; INIT_TIMED_CALL_SYMBOL : INDICATOR_LENGTH_1 ; INIT_CONDITIONAL_CALL_SYMBOL : INDICATOR_LENGTH_1 ; INIT_GUARDED_ENTRY_SYMBOL : INDICATOR_LENGTH_1 ; INIT_GENERIC_DECL_SYMBOL : INDICATOR_LENGTH_2 ; INIT_GENERIC_INST_SYMBOL : INDICATOR_LENGTH_2 ; INIT_TASK_TYPE_SYMBOL : INDICATOR_LENGTH_4 ; end case ; end record ; package NODE_IO is new DIRECT_IO (IO_NODE_TYPE); use NODE_IO; FILE_HANDLE : FILE_TYPE; IO_NODE : IO_NODE_TYPE; IO_ATTRIBUTE : IO_NODE_TYPE(ATTRIBUTE_HEADER_RECORD) ; RECORD_COUNT : INTEGER; function COMPLETE_FILE_NAME ( FILE_NAME : FILENAME_TYPE ; EXTENSION : EXTENSION_TYPE ) return TOTAL_FILENAME_TYPE is -- use the file name to the first space and append the extension -- to create a valid system file name. FINISHED_NAME : TOTAL_FILENAME_TYPE ; FIRST_CHAR : Natural := 0 ; END_OF_NAME : Natural := 0 ; NAME_LENGTH : Natural := 0 ; FOUND_START : Boolean := False ; SPACE : constant CHARACTER := ' ' ; begin -- COMPLETE_FILE_NAME if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "TREE_IO.COMPLETE_FILE_NAME" & " => [" & FILE_NAME & EXTENSION & "]" ) ; end if ; if FILE_NAME = NULL_FILENAME then return DEFAULT_FILENAME & EXTENSION ; else -- check each character in the name for a space or control character for I in FILE_NAME'Range loop if FILE_NAME( I ) = SPACE or FILE_NAME( I ) = ASCII.NUL then if FOUND_START then -- calc the size of the new file name NAME_LENGTH := END_OF_NAME - FIRST_CHAR + 1 ; -- send back the name with extension return NULL_FILENAME( 1..MAX_FILENAME_SIZE-NAME_LENGTH ) & FILE_NAME( FIRST_CHAR..END_OF_NAME ) & EXTENSION ; exit ; else -- all spaces so far END_OF_NAME := I ; end if ; else if not FOUND_START then FIRST_CHAR := I ; FOUND_START := True ; END_OF_NAME := I ; else -- still a good name so keep checking END_OF_NAME := I ; end if ; end if ; end loop ; -- full name was used send back the name with extension return FILE_NAME & EXTENSION ; end if ; end COMPLETE_FILE_NAME ; procedure READ ( FILE: in TOTAL_FILENAME_TYPE ) is -- read the specified page into the arrays in -- the package TREE_DATA. Set all necessary -- parameters based on the values in the file -- (possibly number of nodes). INDEX : NATURAL := 0; begin -- try to open the file to be read begin OPEN (FILE_HANDLE, IN_FILE, FILE); exception when others => --- TEXT_IO.PUT_LINE (" unable to open file "); --Debug raise INVALID_FILE_SPECIFIER; end; -- compute the maximum number of records to be read RECORD_COUNT := MAX_GRAPH_NODES; if MAX_LIST_NODES > RECORD_COUNT then RECORD_COUNT := MAX_LIST_NODES; end if; if MAX_TREE_NODES > RECORD_COUNT then RECORD_COUNT := MAX_TREE_NODES; end if; if MAX_PROLOGUE_NODES > RECORD_COUNT then RECORD_COUNT := MAX_PROLOGUE_NODES; end if; -- read in attributes READ (FILE_HANDLE, IO_ATTRIBUTE); ENTITY_COLOR := IO_ATTRIBUTE.INIT_ENTITY_COLOR ; ENTITY_LINE := IO_ATTRIBUTE.INIT_ENTITY_LINE ; FUNCTION_SYMBOL := IO_ATTRIBUTE.INIT_FUNCTION_SYMBOL ; NORMAL_REFERENCE_SYMBOL := IO_ATTRIBUTE.INIT_NORMAL_REFERENCE_SYMBOL ; VIRTUAL_REFERENCE_SYMBOL := IO_ATTRIBUTE.INIT_VIRTUAL_REFERENCE_SYMBOL ; TIMED_CALL_SYMBOL := IO_ATTRIBUTE.INIT_TIMED_CALL_SYMBOL ; CONDITIONAL_CALL_SYMBOL := IO_ATTRIBUTE.INIT_CONDITIONAL_CALL_SYMBOL ; GUARDED_ENTRY_SYMBOL := IO_ATTRIBUTE.INIT_GUARDED_ENTRY_SYMBOL ; GENERIC_DECL_SYMBOL := IO_ATTRIBUTE.INIT_GENERIC_DECL_SYMBOL ; GENERIC_INST_SYMBOL := IO_ATTRIBUTE.INIT_GENERIC_INST_SYMBOL ; TASK_TYPE_SYMBOL := IO_ATTRIBUTE.INIT_TASK_TYPE_SYMBOL ; -- read in the records loop -- compute the number of the record to be read INDEX := INDEX + 1; -- check if the number is valid and if it exists if END_OF_FILE (FILE_HANDLE) then exit; elsif INDEX > RECORD_COUNT then TEXT_IO.PUT_LINE (" too many records for the arrays "); exit; end if; -- read the record READ (FILE_HANDLE, IO_NODE); --- TEXT_IO.PUT ('.'); --Debug --- if INDEX mod 50 = 0 then --Debug --- TEXT_IO.NEW_LINE; --Debug --- end if; --Debug -- unpack the nodes from the IO_NODE record if INDEX <= MAX_GRAPH_NODES then GRAPH(INDEX) := IO_NODE.GRAPH_NODE; end if; if INDEX <= MAX_LIST_NODES then LIST(INDEX) := IO_NODE.LIST_NODE; end if; if INDEX <= MAX_TREE_NODES then TREE(INDEX) := IO_NODE.TREE_NODE; end if; if INDEX <= MAX_PROLOGUE_NODES then PROLOGUE(INDEX) := IO_NODE.PROLOGUE_NODE; end if; end loop; -- close the file CLOSE (FILE_HANDLE); --- TEXT_IO.NEW_LINE; --Debug exception when others => if IS_OPEN (FILE_HANDLE) then CLOSE (FILE_HANDLE); end if; raise; end READ; procedure WRITE ( FILE: in TOTAL_FILENAME_TYPE ) is -- Write the contents of the arrays in the -- package TREE_DATA to the specified file. INDEX : NATURAL := 0; begin -- compute the number of records to be written RECORD_COUNT := MAX_GRAPH_NODES; if MAX_LIST_NODES > RECORD_COUNT then RECORD_COUNT := MAX_LIST_NODES; end if; if MAX_TREE_NODES > RECORD_COUNT then RECORD_COUNT := MAX_TREE_NODES; end if; if MAX_PROLOGUE_NODES > RECORD_COUNT then RECORD_COUNT := MAX_PROLOGUE_NODES; end if; -- create the file to be written begin CREATE (FILE_HANDLE, OUT_FILE, FILE , FORM => "RECORD ; SIZE 512 " ); exception when others => raise INVALID_FILE_SPECIFIER; end; -- write out attributes IO_ATTRIBUTE.INIT_ENTITY_COLOR := ENTITY_COLOR ; IO_ATTRIBUTE.INIT_ENTITY_LINE := ENTITY_LINE ; IO_ATTRIBUTE.INIT_FUNCTION_SYMBOL := FUNCTION_SYMBOL ; IO_ATTRIBUTE.INIT_NORMAL_REFERENCE_SYMBOL := NORMAL_REFERENCE_SYMBOL ; IO_ATTRIBUTE.INIT_VIRTUAL_REFERENCE_SYMBOL := VIRTUAL_REFERENCE_SYMBOL ; IO_ATTRIBUTE.INIT_TIMED_CALL_SYMBOL := TIMED_CALL_SYMBOL ; IO_ATTRIBUTE.INIT_CONDITIONAL_CALL_SYMBOL := CONDITIONAL_CALL_SYMBOL ; IO_ATTRIBUTE.INIT_GUARDED_ENTRY_SYMBOL := GUARDED_ENTRY_SYMBOL ; IO_ATTRIBUTE.INIT_GENERIC_DECL_SYMBOL := GENERIC_DECL_SYMBOL ; IO_ATTRIBUTE.INIT_GENERIC_INST_SYMBOL := GENERIC_INST_SYMBOL ; IO_ATTRIBUTE.INIT_TASK_TYPE_SYMBOL := TASK_TYPE_SYMBOL ; WRITE (FILE_HANDLE, IO_ATTRIBUTE); -- write out the records loop -- compute the number of the record to be written INDEX := INDEX + 1; -- exit when all the records have been written if INDEX > RECORD_COUNT then exit; end if; -- pack the nodes from the IO_NODE record if INDEX <= MAX_GRAPH_NODES then IO_NODE.GRAPH_NODE := GRAPH(INDEX); end if; if INDEX <= MAX_LIST_NODES then IO_NODE.LIST_NODE := LIST(INDEX); end if; if INDEX <= MAX_TREE_NODES then IO_NODE.TREE_NODE := TREE(INDEX); end if; if INDEX <= MAX_PROLOGUE_NODES then IO_NODE.PROLOGUE_NODE := PROLOGUE(INDEX); end if; -- write out the record WRITE (FILE_HANDLE, IO_NODE); --- TEXT_IO.PUT ('.'); --Debug --- if INDEX mod 50 = 0 then --Debug --- TEXT_IO.NEW_LINE; --Debug --- end if; --Debug end loop; -- close the file CLOSE (FILE_HANDLE); --- TEXT_IO.NEW_LINE; --Debug exception when others => if IS_OPEN (FILE_HANDLE) then CLOSE (FILE_HANDLE); end if; raise; end WRITE; begin -- TREE_IO -- aggragate initialization of null filename for I in FILENAME_TYPE'First..FILENAME_TYPE'Last loop NULL_FILENAME( I ) := ASCII.NUL ; end loop ; -- aggragate initialization of default filename for I in FILENAME_TYPE'First..FILENAME_TYPE'Last-8 loop DEFAULT_FILENAME( I ) := ASCII.NUL ; end loop ; DEFAULT_FILENAME(FILENAME_TYPE'last-7..FILENAME_TYPE'Last) := "DATAFILE" ; -- aggragate initialization of initial data_filename DATA_FILENAME := DEFAULT_FILENAME ; end TREE_IO; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --gks_non_standard_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- VERSION 85-08-28 14:50 by RAM with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; package GKS_NON_STANDARD is -- ============================================================ -- This package implements a version of the Graphical -- Kernel System (GKS) developed by SYSCON Corporation -- for use with the Graphic Ada Designer. The specification -- is based on: -- -- 1) The Ada Phase I GKS developed by Harris Corp. -- 2) Draft GKS Binding to ANSI Ada -- -- This implementation will initially be a partial subset, -- with only those operations required by the Graphic Ada -- Designer implemented. Although the semantics of the -- functions implemented are intended to be faithful to those -- decribed in the GKS Binding, the goal of efficiency and -- compactness may result in the implementation code ignoring -- certain arguments (e.g., opening a workstation may be -- unnecessary and implemented as a null operation). The -- code will directly manipulate primitives of the target -- graphics device, without the intermediate operations -- associated with GKS. The implementation and utilization -- of this package will be faithful enough to the real GKS, -- to permit the Graphic Ada Designer to be easily converted -- to using a real version of GKS. -- -- NOTE : this partition contains the non standard gks operations -- ============================================================ --------------------------------------------------------------------- -- Determine type of generalized drawing primitive (GDP) requested. -- All GDP functions based on a two point definition point list -- to completely describe the location of the entity, the two points -- define a box that is used for a rectangle or show the outer limits -- of the circles location using the first (upper left) point as the -- standard reference. --------------------------------------------------------------------- package FROM_LEVEL_0A is -- ======================================================== -- This packages declares the Level 0A operations of GKS. -- ======================================================== procedure ESCAPE ( ESCAPE_ID : ESCAPE_IDENTIFIER ; ESCAPE_DATA : ESCAPE_RECORD ) ; -- ===================================================== -- A standard way of invoking non-standard features -- ISO/DIS 7942, section 5.2, page 86 -- Effect : The specified non-standard specific escape -- function is invoked. -- ===================================================== procedure GDP ( POINTS : in GKS_SPECIFICATION.WC.POINT_ARRAY ; GDP_IDENTIFIER : in GKS_SPECIFICATION.GDP_ID ) ; -- ================================================================ -- Generate a generalized drawing primitive defined by a sequence -- of points in WC and a data record -- ISO/DIS 7942, section 5.3, page 91 -- Effect : A generalized drawing primitive (GDP) of the type -- indicated by the GDP identifier is generated on the basis -- of the given points and the GDP data record. -- ================================================================ end FROM_LEVEL_0A ; end GKS_NON_STANDARD ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --gks_non_standard_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-10-21 11:20 by RAM with TERMINAL_ACCESS ; use TERMINAL_ACCESS ; with TRACE_PKG ; use TRACE_PKG ; package body GKS_NON_STANDARD is -- =========================================================== -- The package body of GKS implements the operations which -- compose levels 0A through 1B. -- -- Terminal_Access Support Requirments -- -- In addition to normal graphics support the -- -- following additions are required. -- -- SEGMENTS : -- -- Open/Create Close -- -- Rename Delete -- -- Priorities -- -- DRAWING : -- -- Boxes Circles -- -- Polylines Text -- -- Regular Polygons Polymarkers -- -- Complex Fill Polygons -- -- -- NOTE : this partition contains the non standard gks operations --------------------------------------------------------- package TERM_ACC renames TERMINAL_ACCESS ; ----------------------------------------------------------------- -- The following object declarations are to set the operation in -- the package terminal_access that will be used to draw each of -- indicated entities. ---------------------------------------------------------------- FOR_CIRCLE : constant TERM_ACC.CIRCLE_OPERATIONS_TYPE := TERM_ACC.CIRCLE_OPERATIONS_TYPE'First ; FOR_FILL_AREA : constant TERM_ACC.FILL_AREA_OPERATIONS_TYPE := TERM_ACC.FILL_AREA_OPERATIONS_TYPE'First ; FOR_POLYLINE : constant TERM_ACC.POLYLINE_OPERATIONS_TYPE := TERM_ACC.POLYLINE_OPERATIONS_TYPE'First ; FOR_POLYMARKER : constant TERM_ACC.POLYMARKER_OPERATIONS_TYPE := TERM_ACC.POLYMARKER_OPERATIONS_TYPE'First ; FOR_RECTANGLE : constant TERM_ACC.RECTANGLE_OPERATIONS_TYPE := TERM_ACC.RECTANGLE_OPERATIONS_TYPE'First ; FOR_TEXT : constant TERM_ACC.TEXT_OPERATIONS_TYPE := TERM_ACC.TEXT_OPERATIONS_TYPE'First ; ----------------------------------------------------------------- -- The following object declarations are to set the indicator in -- the package terminal_access that will be used to draw each of -- indicated entity types color. ------------------------------------------------------------------ FOR_ALPHA_BACKGROUND : constant TERM_ACC.FOR_ALPHA_BACKGROUND_TYPE := TERM_ACC.FOR_ALPHA_BACKGROUND_TYPE'First ; FOR_ALPHA_WRITING : constant TERM_ACC.FOR_ALPHA_WRITING_TYPE := TERM_ACC.FOR_ALPHA_WRITING_TYPE'First ; FOR_GRAPHIC_BACKGROUND : constant TERM_ACC.FOR_GRAPHIC_BACKGROUND_TYPE := TERM_ACC.FOR_GRAPHIC_BACKGROUND_TYPE'First ; FOR_CHARACTER : constant TERM_ACC.FOR_CHARACTER_COLOR_TYPE := TERM_ACC.FOR_CHARACTER_COLOR_TYPE'First ; FOR_FILL_STYLE : constant TERM_ACC.FOR_FILL_STYLE_COLOR_TYPE := TERM_ACC.FOR_FILL_STYLE_COLOR_TYPE'First ; FOR_LINE_STYLE : constant TERM_ACC.FOR_LINE_STYLE_COLOR_TYPE := TERM_ACC.FOR_LINE_STYLE_COLOR_TYPE'First ; FOR_MARKERS : constant TERM_ACC.FOR_MARKERS_COLOR_TYPE := TERM_ACC.FOR_MARKERS_COLOR_TYPE'First ; package body FROM_LEVEL_0A is -- =============================================================== -- This package body implements the Level 0A operations of GKS. -- =============================================================== procedure ESCAPE ( ESCAPE_ID : ESCAPE_IDENTIFIER ; ESCAPE_DATA : ESCAPE_RECORD ) is -- =============================================================== -- A standard way of invoking non-standard features -- ISO/DIS 7942, section 5.2, page 86 -- Effect : The specified non-standard specific escape -- function is invoked. -- =============================================================== SEGMENT_ID : SEGMENT_NAME ; UPPER_LEFT_VIEW , LOWER_RIGHT_VIEW , UPPER_LEFT_WINDOW , LOWER_RIGHT_WINDOW : WC.POINT ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.ESCAPE" ) ; end if ; case ESCAPE_ID is when ALPHA_BACKGROUND => TERM_ACC.SET_COLOR_INDEX ( FOR_ALPHA_BACKGROUND , ESCAPE_DATA.COLOUR ) ; when ALPHA_WRITING => TERM_ACC.SET_COLOR_INDEX ( FOR_ALPHA_WRITING , ESCAPE_DATA.COLOUR ) ; when GRAPHIC_BACKGROUND => TERM_ACC.SET_COLOR_INDEX ( FOR_GRAPHIC_BACKGROUND , ESCAPE_DATA.COLOUR ) ; when GRAPHICS_VISIBILITY => TERM_ACC.GRAPHICS_SCREEN ( ESCAPE_DATA.GRAPHICS_ON ) ; when PRINT_SCREEN => TERM_ACC.PRINT_SCREEN ; when PRINT_WINDOW => TERM_ACC.PRINT_SCREEN( ESCAPE_DATA.WINDOW ) ; when SEGMENT_MOVEMENT => -- load data from escape_record SEGMENT_ID := ESCAPE_DATA.SEGMENT ; TERM_ACC.MOVE_SEGMENT ( SEGMENT_ID , ESCAPE_DATA.POSITION ) ; when SELECT_WINDOW => TERM_ACC.SET_CURRENT_WINDOW ( ESCAPE_DATA.WINDOW ) ; when MAP_WINDOW_TO_VIEWPORT => UPPER_LEFT_VIEW.X := ESCAPE_DATA.VIEW_RECTANGLE.X.MIN ; UPPER_LEFT_VIEW.Y := ESCAPE_DATA.VIEW_RECTANGLE.Y.MAX ; LOWER_RIGHT_VIEW.X := ESCAPE_DATA.VIEW_RECTANGLE.X.MAX ; LOWER_RIGHT_VIEW.Y := ESCAPE_DATA.VIEW_RECTANGLE.Y.MIN ; UPPER_LEFT_WINDOW.X := ESCAPE_DATA.WINDOW_RECTANGLE.X.MIN ; UPPER_LEFT_WINDOW.Y := ESCAPE_DATA.WINDOW_RECTANGLE.Y.MAX ; LOWER_RIGHT_WINDOW.X := ESCAPE_DATA.WINDOW_RECTANGLE.X.MAX ; LOWER_RIGHT_WINDOW.Y := ESCAPE_DATA.WINDOW_RECTANGLE.Y.MIN ; TERM_ACC.MAP_WINDOW_TO_VIEWPORT ( ESCAPE_DATA.VIEW_WINDOW_ID , UPPER_LEFT_WINDOW , LOWER_RIGHT_WINDOW , UPPER_LEFT_VIEW , LOWER_RIGHT_VIEW ) ; when others => null ; end case ; -- ESCAPE_ID end ESCAPE ; procedure GDP ( POINTS : in WC.POINT_ARRAY ; GDP_IDENTIFIER : in GDP_ID ) is -- =============================================================== -- Generate a generalized drawing primitive defined by a sequence -- of points in WC and a data record -- ISO/DIS 7942, section 5.3, page 91 -- Effect : A generalized drawing primitive (GDP) of the type -- indicated by the GDP identifier is generated on the -- basis of the given points and the GDP data record. -- =============================================================== GDP_CIRCLE_DATA : TERM_ACC.OBJECT_DATA_RECORD( FOR_CIRCLE ) ; GDP_RECTANGLE_DATA : TERM_ACC.OBJECT_DATA_RECORD( FOR_RECTANGLE ) ; SIDES_FOR_CIRCLE : constant NATURAL := 36 ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.GDP" ) ; end if ; case GDP_IDENTIFIER is when GDP_RECTANGLE => -- fill gdp_rectangle_data with specific data GDP_RECTANGLE_DATA.REFERENCE_POINT := POINTS ( 1 ) ; GDP_RECTANGLE_DATA.SIZE_POINT := POINTS ( 2 ) ; TERM_ACC.DRAW ( GDP_RECTANGLE_DATA ) ; when GDP_CIRCLE => -- fill gdp_circle_data with specific data GDP_CIRCLE_DATA.REFERENCE_POINT := POINTS ( 1 ) ; GDP_CIRCLE_DATA.SIZE_POINT := POINTS ( 2 ) ; TERM_ACC.DRAW ( GDP_CIRCLE_DATA ) ; when others => null ; end case ; end GDP ; end FROM_LEVEL_0A ; end GKS_NON_STANDARD ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --gks_prime_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- VERSION 85-11-06 08:00 by JB -- -- THIS VERSION IS CALL COMPATIBLE WITH HARRIS/ADA GKS with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; package GKS_PRIME is -- ============================================================ -- This package implements a version of the Graphical -- Kernel System (GKS) developed by SYSCON Corporation -- for use with the Graphic Ada Designer. The specification -- is based on: -- -- 1) The Ada Phase I GKS developed by Harris Corp. -- 2) Draft GKS Binding to ANSI Ada -- -- This implementation will initially be a partial subset, -- with only those operations required by the Graphic Ada -- Designer implemented. Although the semantics of the -- functions implemented are intended to be faithful to those -- decribed in the GKS Binding, the goal of efficiency and -- compactness may result in the implementation code ignoring -- certain arguments (e.g., opening a workstation may be -- unnecessary and implemented as a null operation). The -- code will directly manipulate primitives of the target -- graphics device, without the intermediate operations -- associated with GKS. The implementation and utilization -- of this package will be faithful enough to the real GKS, -- to permit the Graphic Ada Designer to be easily converted -- to using a real version of GKS. -- ============================================================ package LEVEL_0A is -- ======================================================== -- This packages declares the Level 0A operations of GKS. -- ======================================================== procedure CLOSE_GKS ; -- ============================================================== -- Stop working with GKS -- ANS GKS section 5.2, page 74 -- Effect : GKS is closed and all termination processing required -- by the implementation is performed. -- ============================================================== procedure CLOSE_WORKSTATION ( WS : in WS_ID ) ; -- ============================================================= -- Release the connection between a workstation and GKS -- ANS GKS, section 5.2, page 75 -- Effect : For the specified workstation, an implicit UPDATE -- WORKSTATION is performed, and the connection to the -- workstation is released. -- ============================================================= procedure EMERGENCY_CLOSE_GKS ; -- =============================================================== -- Tries to close GKS in case of an error, saving as much information -- as possible -- ANS GKS, section 5.11, page 195 -- Effect : GKS is emergency closed. The function is called when it -- is not possible to recover from an error. -- =============================================================== procedure ERROR_HANDLING ( ERROR_NUMBER : in ERROR_INDICATOR ; ID : in SUBPROGRAM_NAME ; ERROR_FILE : in STRING ) ; -- =============================================================== -- A procedure called by GKS when an error is detected. It may be -- user supplied -- ANS GKS, section 5.11, page 195 -- Effect : The GKS detected error is logged via a call to -- ERROR_LOGGING and control is returned to the GKS -- function where the error has been detected. -- ============================================================== procedure ERROR_LOGGING ( EI : in ERROR_INDICATOR ; NAME : in SUBPROGRAM_NAME ) ; -- ============================================================== -- A procedure called by the standard GKS error handling procedure. -- It prints an error message and function identification on the -- error file -- ANS GKS, section 5.11, page 196 -- Effect : An error message and GKS function identification is -- written to the error file. -- ============================================================== procedure FILL_AREA ( FILL_AREA_POINTS : in WC.POINT_ARRAY ) ; -- ================================================================ -- Generate a polygon which may be filled with a colour, a hatch or -- a pattern or may be hollow -- ANS GKS, section 5.3, page 83 -- Effect : A FILL AREA primitive is generated, and the current values -- of the fill area attributes are bound to the primitive. -- The attributes are listed in section 4.4.2, page 21. -- ================================================================ procedure OPEN_GKS ( ERROR_FILE : in ERROR_FILE_TYPE := DEFAULT_ERROR_FILE ; AMOUNT_OF_MEMORY : in MEMORY_UNITS := MAX_MEMORY_UNITS ) ; -- ============================================================= -- Start working with GKS -- ANS GKS, section 5.2, page 74 -- Effect : GKS is opened and all initialization processing required -- by the implementation is performed. -- ============================================================== procedure OPEN_WORKSTATION ( WS : in WS_ID ; CONNECTION : in CONNECTION_ID ; TYPE_OF_WS : in WS_TYPE ) ; -- ============================================================ -- Create a connection between a workstation and GKS -- ANS GKS, section 5.2, page 74 -- Effect : Specifies the number to be used to identify the -- workstation, requests the specified connection to -- the workstation, and, if needed, clears the display -- surface. -- ============================================================ procedure POLYLINE ( LINE_POINTS : in WC.POINT_ARRAY ) ; -- ============================================================ -- Generate a polyline defined by points in WC -- ANS GKS, section 5.3, page 82 -- Effect : A sequence of connected straight lines is generated, -- starting at the first point and ending at the last point. -- ============================================================ procedure POLYMARKER ( MARKER_POINTS : in WC.POINT_ARRAY ) ; -- ============================================================ -- Generate markers of a given type at positions in WC -- ANS GKS, section 5.3, page 82 -- Effect : A sequence of markers is generated to identify all the -- given positions. -- ============================================================ procedure SET_CHAR_EXPANSION_FACTOR( EXPANSION : in CHAR_EXPANSION ) ; -- =================================================================== -- Set the expansion factor used to determine character width. -- ANS GKS section 5.4, page 93 -- Effect : The 'current character expansion factor' entry in the GKS -- state list is set to the value specified by the parameter. -- =================================================================== procedure SET_CHAR_SPACING( SPACING : in CHAR_SPACING ) ; -- =================================================================== -- Set the spacing between text characters. -- ANS GKS section 5.4, page 94 -- Effect : The 'current character spacing' entry in the GKS state -- list is set to the value specified by the parameter. -- =================================================================== procedure SET_CHAR_HEIGHT( HEIGHT : in WC.MAGNITUDE ) ; -- =================================================================== -- Set the text characters height. -- ANS GKS section 5.4, page 94 -- Effect : The 'current character height'entry in the GKS state -- list is set to the value specified by the parameter. -- =================================================================== procedure SET_COLOUR_REPRESENTATION ( WS : in WS_ID ; INDEX : in COLOUR_INDEX ; COLOUR : in COLOUR_REPRESENTATION ) ; -- ============================================================ -- Define the colour to be associated with a colour index on -- a workstation -- ANS GKS, section 5.4, page 105 -- Effect : Redefines the entries in the colour look up table pointed -- at by the colour index. -- ============================================================ procedure SET_FILL_AREA_COLOUR_INDEX ( COLOUR : in COLOUR_INDEX ) ; -- ============================================================ -- Set the fill area colour index for use when the corresponding -- ASF is INDIVIDUAL -- ANS GKS, section 5.4, page 98 -- Effect : The current fill area colour index is set to the -- specified value. -- ============================================================ procedure SET_FILL_AREA_INTERIOR_STYLE ( STYLE : in INTERIOR_STYLE ) ; -- ============================================================ -- Set the fill area interior style for use when the corresponding -- ASF is INDIVIDUAL -- ANS GKS, section 5.4, page 96 -- Effect : The current fill area interior style is set to the -- specified value. -- ============================================================ procedure SET_LINE_TYPE ( LINE : in LINE_TYPE ) ; -- ============================================================ -- Set the linetype for use when the corresponding ASF -- is INDIVIDUAL -- ANS GKS, section 5.4, page 89 -- Effect : The current line type is set to the specified value. -- Linetypes: -- 1 - solid -- 2 - dashed -- 3 - dotted -- 4 - dashed-dotted -- >4 - implementation dependent -- ============================================================ procedure SET_MARKER_TYPE ( MARKER : in MARKER_TYPE ) ; -- ============================================================ -- Set the marker type for use when the corresponding ASF -- is INDIVIDUAL -- ANS GKS, section 5.4, page 91 -- Effect : The current marker type is set to the specified value. -- Marker types: -- 1 - dot -- 2 - plus sign -- 3 - asterisk -- 4 - circle -- 5 - diagonal cross -- >5 - implementation dependent -- ============================================================ procedure SET_POLYLINE_COLOUR_INDEX ( COLOUR : in COLOUR_INDEX ) ; -- ============================================================ -- Set the polyline colour index for use when the corresponding ASF -- is INDIVIDUAL -- ANS GKS, section 5.4, page 90 -- Effect : The current polyline colour index is set to the -- specified value. -- ============================================================ procedure SET_POLYMARKER_COLOUR_INDEX ( COLOUR : in COLOUR_INDEX ) ; -- ============================================================ -- Set the polymarker colour index for use when the corresponding -- ASF is INDIVIDUAL -- ANS GKS, section 5.4, page 92 -- Effect : The current polymarker colour index is set to the -- specified value. -- ============================================================ procedure SET_TEXT_COLOUR_INDEX ( COLOUR : in COLOUR_INDEX ) ; -- ============================================================ -- Set the text colour index for use when the corresponding -- ASF is INDIVIDUAL -- ANS GKS, section 5.4, page 94 -- Effect : The current text colour index is set to the -- specified value. -- ============================================================ procedure SET_TEXT_FONT_AND_PRECISION ( FONT_PRECISION : in TEXT_FONT_PRECISION ) ; -- ============================================================ -- Set the text font and precision for use when the -- corresponding ASF is INDIVIDUAL -- ANS GKS, section 5.4, page 94 -- Effect : The 'current text font and precision' entry in the -- GKS state list is set to the value specified by -- the parameter. -- ============================================================ procedure SET_TEXT_PATH ( PATH : in TEXT_PATH ) ; -- ============================================================ -- Select the text path RIGHT, LEFT, UP, or DOWN -- ANS GKS, section 5.4, page 95 -- Effect : Set the text path of character strings to the specified -- values for all subsequent text output primitives until -- the values are reset by another call to this function. -- ============================================================ procedure SET_WINDOW ( TRANSFORMATION : in TRANSFORMATION_NUMBER ; WINDOW_LIMITS : in WC.RECTANGLE_LIMITS ) ; -- ============================================================ -- Set window in WC of a normalization transformation -- ANS GKS, section 5.5, page 107 -- Effect : Defines a window for the specified normalization -- transformation. -- ============================================================ procedure SET_WORKSTATION_VIEWPORT ( WS : in WS_ID ; WS_VIEWPORT_LIMITS : in DC.RECTANGLE_LIMITS ) ; -- ============================================================ -- Set workstation viewport in DC -- ANS GKS, section 5.5, page 109 -- Effect : Specifies where on the workstation display the view -- of NDC space will appear. -- ============================================================ procedure TEXT ( POSITION : in WC.POINT ; CHAR_STRING : in STRING ) ; -- ============================================================ -- Generate a text string at the given position in WC -- ANS GKS, section 5.3, page 83 -- Effect : Generates the specified text string at the specified -- position. -- ============================================================ end LEVEL_0A ; package LEVEL_0B is -- ============================================================ -- This package declares the GKS Level 0B operations. -- ============================================================ procedure INITIALISE_LOCATOR ( WS : in WS_ID ; DEVICE : in DEVICE_NUMBER ; INITIAL_TRANSFORMATION : in TRANSFORMATION_NUMBER ; INITIAL_POSITION : in WC.POINT ; ECHO_AREA : in DC.RECTANGLE_LIMITS ; DATA_RECORD : in LOCATOR_DATA_RECORD ) ; -- ============================================================ -- Initializes a device for the work station so that a request -- from the locator device can be made -- ANS GKS, section 5.7, page 119 -- Effect : Initializes a request on the specified locator device. -- ============================================================ procedure REQUEST_LOCATOR ( WS : in WS_ID ; DEVICE : in DEVICE_NUMBER ; STATUS : out INPUT_STATUS ; TRANSFORMATION : out TRANSFORMATION_NUMBER ; POSITION : out WC.POINT ) ; -- ============================================================ -- Request position in WC and normalization transformation number -- from a locator device -- ANS GKS, section 5.7, page 131 -- Effect : Perform a request on the specified locator device. -- ============================================================ end LEVEL_0B ; package LEVEL_1A is -- ============================================================ -- This package declares the GKS Level 1A operations. -- ============================================================ procedure CLOSE_SEGMENT ; -- ============================================================ -- Segment construction finished -- ANS GKS, section 5.6, page 111 -- Effect : Close the currently open segment. Primitives may no longer -- be added to the closed segment. -- ============================================================ procedure CREATE_SEGMENT ( SEGMENT : in SEGMENT_NAME ) ; -- ============================================================ -- Create a segment and start constructing it -- ANS GKS, section 5.6, page 111 -- Effect : Create a segment. Subsequent calls to output primitive -- functions will place the primitives into the currently -- open segment. -- ============================================================ procedure DELETE_SEGMENT ( SEGMENT : in SEGMENT_NAME ) ; -- ============================================================ -- Delete a segment -- ANS GKS, section 5.6, page 112 -- Effect : Delete all copies of the specified segment stored in -- GKS. The segment name may be reused. -- ============================================================ procedure REDRAW_ALL_SEGMENTS_ON_WORKSTATION ( WS : in WS_ID ) ; -- ============================================================ -- Redraw all visible segments stored on a workstation -- ANS GKS, section 5.2, page 77 -- Effect : For the specified workstation, all deferred actions are -- executed, the display surface is cleared if not empty, -- and all visible segments are displayed. -- ============================================================ procedure RENAME_SEGMENT ( OLD_NAME : in SEGMENT_NAME ; NEW_NAME : in SEGMENT_NAME ) ; -- ============================================================ -- Change name of a segment -- ANS GKS, section 5.6, page 111 -- Effect : Rename the specified segment. The old segment name -- may be reused. -- ============================================================ procedure SET_HIGHLIGHTING ( SEGMENT : in SEGMENT_NAME ; HIGHLIGHTING : in SEGMENT_HIGHLIGHTING ) ; -- ============================================================ -- Mark segment normal or highlighted -- ANS GKS, section 5.6, page 116 -- Effect : Set the highlighting attribute to the value -- HIGHLIGHTED or NORMAL. -- ============================================================ procedure SET_SEGMENT_PRIORITY ( SEGMENT : in SEGMENT_NAME ; PRIORITY : in SEGMENT_PRIORITY ) ; -- ============================================================ -- Set priority of a segment -- ANS GKS, section 5.6, page 117 -- Effect : Set the priority of the specified segment to the specified -- priority. Priority is a value in the range 0 to 1. -- ============================================================ procedure SET_VISIBILITY ( SEGMENT : in SEGMENT_NAME ; VISIBILITY : in SEGMENT_VISIBILITY ) ; -- ============================================================ -- Mark segment visible or invisible -- ANS GKS, section 5.6, page 116 -- Effect : Set the visibility attributes of the specified segment -- to VISIBLE or INVISIBLE. -- ============================================================ end LEVEL_1A ; package LEVEL_1B is -- ============================================================ -- This package declares the GKS Level 1B operations. -- ============================================================ procedure REQUEST_PICK ( WS : in WS_ID ; DEVICE : in DEVICE_NUMBER ; STATUS : out PICK_REQUEST_STATUS ; SEGMENT : out SEGMENT_NAME ; PICK : out PICK_ID ) ; -- ============================================================ -- Request segment name, pick identifier and pick status from a -- pick device -- ANS GKS5.7, section 5.7, page 134 -- Effect : Perform a request on the specified pick device. -- ============================================================ procedure SET_DETECTABILITY ( SEGMENT : in SEGMENT_NAME; DETECTABILITY : in SEGMENT_DETECTABILITY ) ; -- ============================================================ -- Mark segment undetectable or detectable -- ANS GKS, section 5.6, page 117 -- Effect : Set the detectability attributes of the specified segment -- to DETECTABLE or UNDETECTABLE. -- ============================================================ end LEVEL_1B ; end GKS_PRIME ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --gks_prime_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-11-27 07:20 by RAM with TEXT_IO ; use TEXT_IO ; with TERMINAL_ACCESS ; use TERMINAL_ACCESS ; with TRACE_PKG ; use TRACE_PKG ; package body GKS_PRIME is -- =========================================================== -- The package body of GKS implements the operations which -- compose levels 0A through 1B. -- -- Terminal_Access Support Requirements -- -- In addition to normal graphics support the -- -- following additions are required. -- -- SEGMENTS : -- -- Open/Create Close -- -- Rename Delete -- -- Priorities -- -- DRAWING : -- -- Boxes Circles -- -- Polylines Text -- -- Regular Polygons Polymarkers -- -- Complex Fill Polygons -- --------------------------------------------------------- package TERM_ACC renames TERMINAL_ACCESS ; ----------------------------------------------------------------- -- The following object declarations are to set the operation in -- the package terminal_access that will be used to draw each of -- indicated entities. ---------------------------------------------------------------- FOR_CIRCLE : constant TERM_ACC.CIRCLE_OPERATIONS_TYPE := TERM_ACC.CIRCLE_OPERATIONS_TYPE'First ; FOR_FILL_AREA : constant TERM_ACC.FILL_AREA_OPERATIONS_TYPE := TERM_ACC.FILL_AREA_OPERATIONS_TYPE'First ; FOR_POLYLINE : constant TERM_ACC.POLYLINE_OPERATIONS_TYPE := TERM_ACC.POLYLINE_OPERATIONS_TYPE'First ; FOR_POLYMARKER : constant TERM_ACC.POLYMARKER_OPERATIONS_TYPE := TERM_ACC.POLYMARKER_OPERATIONS_TYPE'First ; FOR_RECTANGLE : constant TERM_ACC.RECTANGLE_OPERATIONS_TYPE := TERM_ACC.RECTANGLE_OPERATIONS_TYPE'First ; FOR_TEXT : constant TERM_ACC.TEXT_OPERATIONS_TYPE := TERM_ACC.TEXT_OPERATIONS_TYPE'First ; ----------------------------------------------------------------- -- The following object declarations are to set the indicator in -- the package terminal_access that will be used to draw each of -- indicated entity types color. ------------------------------------------------------------------ FOR_ALPHA_BACKGROUND : constant TERM_ACC.FOR_ALPHA_BACKGROUND_TYPE := TERM_ACC.FOR_ALPHA_BACKGROUND_TYPE'First ; FOR_ALPHA_WRITING : constant TERM_ACC.FOR_ALPHA_WRITING_TYPE := TERM_ACC.FOR_ALPHA_WRITING_TYPE'First ; FOR_GRAPHIC_BACKGROUND : constant TERM_ACC.FOR_GRAPHIC_BACKGROUND_TYPE := TERM_ACC.FOR_GRAPHIC_BACKGROUND_TYPE'First ; FOR_CHARACTER : constant TERM_ACC.FOR_CHARACTER_COLOR_TYPE := TERM_ACC.FOR_CHARACTER_COLOR_TYPE'First ; FOR_FILL_STYLE : constant TERM_ACC.FOR_FILL_STYLE_COLOR_TYPE := TERM_ACC.FOR_FILL_STYLE_COLOR_TYPE'First ; FOR_LINE_STYLE : constant TERM_ACC.FOR_LINE_STYLE_COLOR_TYPE := TERM_ACC.FOR_LINE_STYLE_COLOR_TYPE'First ; FOR_MARKERS : constant TERM_ACC.FOR_MARKERS_COLOR_TYPE := TERM_ACC.FOR_MARKERS_COLOR_TYPE'First ; ------------------------- -- current marker in use ------------------------- POLYMARKER_TEXT : STRING ( 1..1 ) := "*" ; --------------------- -- GKS internal files --------------------- ERROR_HISTORY : TEXT_IO.FILE_TYPE ; --------------------- -- GKS state list --------------------- type GKS_STATE_LIST_RECORD is record CURRENT_CHARACTER_EXPANSION_FACTOR : CHAR_EXPANSION := 1.0 ; CURRENT_CHARACTER_SPACING : CHAR_SPACING := 0.0 ; CURRENT_CHARACTER_HEIGHT : WC.MAGNITUDE := 0.01 ; CURRENT_WINDOW : WC.RECTANGLE_LIMITS := ( X => ( MIN => 0.0, MAX => 32_767.0 ), Y => ( MIN => 0.0, MAX => 32_767.0 )) ; -- The following state list entries are non standard. CURRENT_CHARACTER_WC_SPACING : WC_TYPE := 100.0 ; CURRENT_CHARACTER_WC_HEIGHT : WC_TYPE := 100.0 ; CURRENT_CHARACTER_WC_WIDTH : WC_TYPE := 100.0 ; CURRENT_WINDOW_HEIGHT : WC_TYPE := 32_767.0 ; end record ; GKS_STATE_LIST : GKS_STATE_LIST_RECORD ; CURRENT_CHARACTER_WIDTH : constant WC.MAGNITUDE := 0.01 ; GKS_ERROR_FILE : ERROR_FILE_TYPE( 1..DEFAULT_ERROR_FILE'Last ) ; package body LEVEL_0A is -- =============================================================== -- This package body implements the Level 0A operations of GKS. -- =============================================================== procedure CLOSE_GKS is -- ============================================================== -- Stop working with GKS -- ANS GKS section 5.2, page 74 -- Effect : GKS is closed and all termination processing required -- by the implementation is performed. -- ============================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "GKS_PRIME.CLOSE_GKS" ) ; end if ; -- internal GKS operations -- check if error file is open if TEXT_IO.IS_OPEN( ERROR_HISTORY ) then -- close error file TEXT_IO.CLOSE ( ERROR_HISTORY ) ; end if ; end CLOSE_GKS ; procedure CLOSE_WORKSTATION ( WS : in WS_ID ) is -- ============================================================= -- Release the connection between a workstation and GKS -- ANS GKS, section 5.2, page 75 -- Effect : For the specified workstation, an implicit UPDATE -- WORKSTATION is performed, and the connection to the -- workstation is released. -- ============================================================= begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.CLOSE_WORKSTATION" ) ; end if ; TERM_ACC.CLOSE_TERMINAL; end CLOSE_WORKSTATION ; procedure EMERGENCY_CLOSE_GKS is -- =============================================================== -- Tries to close GKS in case of an error, saving as much information -- as possible -- ANS GKS, section 5.11, page 195 -- Effect : GKS is emergency closed. The function is called when it -- is not possible to recover from an error. -- =============================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.EMERGENCY_CLOSE_GKS" ) ; end if ; -- internal GKS operations -- check if error file is open if TEXT_IO.IS_OPEN( ERROR_HISTORY ) then -- close error file TEXT_IO.CLOSE ( ERROR_HISTORY ) ; end if ; end EMERGENCY_CLOSE_GKS ; procedure ERROR_HANDLING ( ERROR_NUMBER : in ERROR_INDICATOR ; ID : in SUBPROGRAM_NAME ; ERROR_FILE : in STRING ) is -- =============================================================== -- A procedure called by GKS when an error is detected. It may be -- user supplied -- ANS GKS, section 5.11, page 195 -- Effect : The GKS detected error is logged via a call to -- ERROR_LOGGING and control is returned to the GKS -- function where the error has been detected. -- ============================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.ERROR_HANDLING" ) ; end if ; -- internal GKS operations ERROR_LOGGING ( ERROR_NUMBER, ID ) ; end ERROR_HANDLING ; procedure ERROR_LOGGING ( EI : in ERROR_INDICATOR ; NAME : in SUBPROGRAM_NAME ) is -- ============================================================== -- A procedure called by the standard GKS error handling procedure. -- It prints an error message and function identification on the -- error file -- ANS GKS, section 5.11, page 196 -- Effect : An error message and GKS function identification is -- written to the error file. -- ============================================================== STORAGE : constant TEXT_IO.FILE_MODE := OUT_FILE ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.ERROR_LOGGING" ) ; end if ; -- check if error file is open if not TEXT_IO.IS_OPEN( ERROR_HISTORY ) then -- open error file TEXT_IO.CREATE( ERROR_HISTORY, STORAGE, GKS_ERROR_FILE ) ; end if ; -- internal GKS operations TEXT_IO.PUT_LINE( ERROR_HISTORY , ERROR_INDICATOR'IMAGE( EI )) ; TEXT_IO.PUT_LINE( ERROR_HISTORY , NAME ) ; end ERROR_LOGGING ; procedure FILL_AREA ( FILL_AREA_POINTS : in WC.POINT_ARRAY ) is -- ================================================================ -- Generate a polygon which may be filled with a colour, a hatch or -- a pattern or may be hollow -- ANS GKS, section 5.3, page 83 -- Effect : A FILL AREA primitive is generated, and the current values -- of the fill area attributes are bound to the primitive. -- The attributes are listed in section 4.4.2, page 21. -- ================================================================ FILL_AREA_DATA : TERM_ACC.OBJECT_DATA_RECORD( FOR_FILL_AREA ) ; MAGNITUDE : constant NATURAL := FILL_AREA_POINTS'last ; EXTENDED_MAGNITUDE : constant NATURAL := MAGNITUDE + 1 ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.FILL_AREA" ) ; end if ; -- fill fill_area_data with point list FILL_AREA_DATA.SHAPE_DATA_LIST ( FILL_AREA_POINTS'first..FILL_AREA_POINTS'last ) := FILL_AREA_POINTS ; FILL_AREA_DATA.SHAPE_LIST_LENGTH := MAGNITUDE ; case FOR_FILL_AREA is when USE_POLYGON => TERM_ACC.DRAW ( FILL_AREA_DATA ) ; when others => null; end case ; end FILL_AREA ; procedure OPEN_GKS ( ERROR_FILE : in ERROR_FILE_TYPE := DEFAULT_ERROR_FILE ; AMOUNT_OF_MEMORY : in MEMORY_UNITS := MAX_MEMORY_UNITS ) is -- ============================================================= -- Start working with GKS -- ANS GKS, section 5.2, page 74 -- Effect : GKS is opened and all initialization processing required -- by the implementation is performed. -- ============================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.OPEN_GKS" ) ; end if ; -- internal GKS operations GKS_ERROR_FILE := ERROR_FILE ; end OPEN_GKS ; procedure OPEN_WORKSTATION ( WS : in WS_ID ; CONNECTION : in CONNECTION_ID ; TYPE_OF_WS : in WS_TYPE ) is -- ============================================================ -- Create a connection between a workstation and GKS -- ANS GKS, section 5.2, page 74 -- Effect : Specifies the number to be used to identify the -- workstation, requests the specified connection to -- the workstation, and, if needed, clears the display -- surface. -- ============================================================ CURRENT_WORKSTATION : WS_ID := WS ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.OPEN_WORKSTATION" ) ; end if ; TERM_ACC.INIT_TERMINAL( CURRENT_WORKSTATION ); end OPEN_WORKSTATION ; procedure POLYLINE ( LINE_POINTS : in WC.POINT_ARRAY ) is -- ============================================================ -- Generate a polyline defined by points in WC -- ANS GKS, section 5.3, page 82 -- Effect : A sequence of connected straight lines is generated, -- starting at the first point and ending at the last point. -- ============================================================ POLYLINE_DATA : TERM_ACC.OBJECT_DATA_RECORD( TERM_ACC.USE_POLYLINE ) ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.POLYLINE" ) ; end if ; -- fill polyline_data with polyline specific data POLYLINE_DATA. SHAPE_DATA_LIST( LINE_POINTS'FIRST..LINE_POINTS'LAST ) := LINE_POINTS ; POLYLINE_DATA. SHAPE_LIST_LENGTH := LINE_POINTS'LAST - LINE_POINTS'FIRST + 1 ; TERM_ACC.DRAW ( POLYLINE_DATA ) ; end POLYLINE ; procedure POLYMARKER ( MARKER_POINTS : in WC.POINT_ARRAY ) is -- ============================================================ -- Generate markers of a given type at positions in WC -- ANS GKS, section 5.3, page 82 -- Effect : A sequence of markers is generated to identify all the -- given positions. -- ============================================================ POLYMARKER_DATA : TERM_ACC.OBJECT_DATA_RECORD( FOR_POLYMARKER ) ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.POLYMARKER" ) ; end if ; case FOR_POLYMARKER is when USE_MARKER => -- fill polymarker_data with marker specific data for I in 1..MARKER_POINTS'last loop POLYMARKER_DATA.REFERENCE_POINT := MARKER_POINTS ( I ) ; TERM_ACC.DRAW ( POLYMARKER_DATA ) ; end loop ; when others => null ; end case ; end POLYMARKER ; procedure SET_CHAR_EXPANSION_FACTOR( EXPANSION : in CHAR_EXPANSION ) is -- =================================================================== -- Set the expansion factor used to determine character width. -- ANS GKS section 5.4, page 93 -- Effect : The 'current character expansion factor' entry in the GKS -- state list is set to the value specified by the parameter. -- =================================================================== SIZE_ATTRIBUTES : TERM_ACC.CHARACTER_ATTRIBUTES ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_CHAR_EXPANSION_FACTOR" ) ; end if ; -- Save received parameter and determine new character width GKS_STATE_LIST.CURRENT_CHARACTER_EXPANSION_FACTOR := EXPANSION ; GKS_STATE_LIST.CURRENT_CHARACTER_WC_WIDTH := GKS_STATE_LIST.CURRENT_WINDOW_HEIGHT * WC_TYPE( CURRENT_CHARACTER_WIDTH ) * WC_TYPE( GKS_STATE_LIST.CURRENT_CHARACTER_EXPANSION_FACTOR ) ; -- Adjust display size of characters SIZE_ATTRIBUTES.WIDTH := GKS_STATE_LIST.CURRENT_CHARACTER_WC_WIDTH ; SIZE_ATTRIBUTES.HEIGHT := GKS_STATE_LIST.CURRENT_CHARACTER_WC_HEIGHT ; SIZE_ATTRIBUTES.SPACING := GKS_STATE_LIST.CURRENT_CHARACTER_WC_SPACING ; TERM_ACC.SET_CHARACTER_ATTRIBUTES( SIZE_ATTRIBUTES ) ; end SET_CHAR_EXPANSION_FACTOR ; procedure SET_CHAR_SPACING( SPACING : in CHAR_SPACING ) is -- =================================================================== -- Set the spacing between text characters. -- ANS GKS section 5.4, page 94 -- Effect : The 'current character spacing' entry in the GKS state -- list is set to the value specified by the parameter. -- =================================================================== SIZE_ATTRIBUTES : TERM_ACC.CHARACTER_ATTRIBUTES ; RECEIVED_SPACING : CHAR_SPACING := SPACING ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_CHAR_SPACING" ) ; end if ; -- Force a positive character expansion if RECEIVED_SPACING < 0.0 then RECEIVED_SPACING := 0.0 ; end if ; -- Save received parameter and determine new character spacing. GKS_STATE_LIST.CURRENT_CHARACTER_SPACING := RECEIVED_SPACING ; GKS_STATE_LIST.CURRENT_CHARACTER_WC_SPACING := GKS_STATE_LIST.CURRENT_WINDOW_HEIGHT * WC_TYPE( GKS_STATE_LIST.CURRENT_CHARACTER_SPACING ) ; -- Adjust display size of characters SIZE_ATTRIBUTES.WIDTH := GKS_STATE_LIST.CURRENT_CHARACTER_WC_WIDTH ; SIZE_ATTRIBUTES.HEIGHT := GKS_STATE_LIST.CURRENT_CHARACTER_WC_HEIGHT ; SIZE_ATTRIBUTES.SPACING := GKS_STATE_LIST.CURRENT_CHARACTER_WC_SPACING ; TERM_ACC.SET_CHARACTER_ATTRIBUTES( SIZE_ATTRIBUTES ) ; end SET_CHAR_SPACING ; procedure SET_CHAR_HEIGHT( HEIGHT : in WC.MAGNITUDE ) is -- =================================================================== -- Set the text characters height. -- ANS GKS section 5.4, page 94 -- Effect : The 'current character height'entry in the GKS state -- list is set to the value specified by the parameter. -- =================================================================== SIZE_ATTRIBUTES : TERM_ACC.CHARACTER_ATTRIBUTES ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_CHAR_HEIGHT" ) ; end if ; -- Save received parameter and determine new character spacing. GKS_STATE_LIST.CURRENT_CHARACTER_HEIGHT := HEIGHT ; GKS_STATE_LIST.CURRENT_CHARACTER_WC_HEIGHT := GKS_STATE_LIST.CURRENT_WINDOW_HEIGHT * WC_TYPE( GKS_STATE_LIST.CURRENT_CHARACTER_HEIGHT ) ; -- Adjust display size of characters SIZE_ATTRIBUTES.WIDTH := GKS_STATE_LIST.CURRENT_CHARACTER_WC_WIDTH ; SIZE_ATTRIBUTES.HEIGHT := GKS_STATE_LIST.CURRENT_CHARACTER_WC_HEIGHT ; SIZE_ATTRIBUTES.SPACING := GKS_STATE_LIST.CURRENT_CHARACTER_WC_SPACING ; TERM_ACC.SET_CHARACTER_ATTRIBUTES( SIZE_ATTRIBUTES ) ; end SET_CHAR_HEIGHT ; procedure SET_COLOUR_REPRESENTATION ( WS : in WS_ID ; INDEX : in COLOUR_INDEX ; COLOUR : in COLOUR_REPRESENTATION ) is -- ============================================================ -- Define the colour to be associated with a colour index on -- a workstation -- ANS GKS, section 5.4, page 105 -- Effect : Redefines the entries in the colour look up table pointed -- at by the colour index. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_COLOUR_REPRESENTATION" ) ; end if ; TERM_ACC.DEFINE_COLOR( INDEX , COLOUR ) ; end SET_COLOUR_REPRESENTATION ; procedure SET_FILL_AREA_COLOUR_INDEX ( COLOUR : in COLOUR_INDEX ) is -- ============================================================ -- Set the fill area colour index for use when the corresponding -- ASF is INDIVIDUAL -- ANS GKS, section 5.4, page 98 -- Effect : The current fill area colour index is set to the -- specified value. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( " " ) ; TRACE_PKG.TRACE ( "GKS_PRIME.SET_FILL_AREA_COLOR_INDEX" ) ; TRACE_PKG.TRACE ( " COLOR =>" & COLOUR_INDEX'Image ( COLOUR ) ) ; end if ; TERM_ACC.SET_COLOR_INDEX ( FOR_FILL_STYLE , COLOUR ) ; end SET_FILL_AREA_COLOUR_INDEX ; procedure SET_FILL_AREA_INTERIOR_STYLE ( STYLE : in INTERIOR_STYLE ) is -- ============================================================ -- Set the fill area interior style for use when the corresponding -- ASF is INDIVIDUAL -- ANS GKS, section 5.4, page 96 -- Effect : The current fill area interior style is set to the -- specified value. -- ============================================================ STYLE_DATA : TERM_ACC.STYLE_RECORD ( FILL_PATTERN ) ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_FILL_AREA_INTERIOR_STYLE" ) ; end if ; -- load style_data STYLE_DATA.FILL := STYLE ; TERM_ACC.SET_STYLE ( STYLE_DATA ) ; end SET_FILL_AREA_INTERIOR_STYLE ; procedure SET_LINE_TYPE ( LINE : in LINE_TYPE ) is -- ============================================================ -- Set the linetype for use when the corresponding ASF -- is INDIVIDUAL -- ANS GKS, section 5.4, page 89 -- Effect : The current line type is set to the specified value. -- Linetypes: -- 1 - solid -- 2 - dashed -- 3 - dotted -- 4 - dashed-dotted -- >4 - implementation dependent -- ============================================================ STYLE_DATA : TERM_ACC.STYLE_RECORD ( LINE_PATTERN ) ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_LINE_TYPE" ) ; end if ; -- load style_data STYLE_DATA.LINE := LINE ; TERM_ACC.SET_STYLE ( STYLE_DATA ) ; end SET_LINE_TYPE ; procedure SET_MARKER_TYPE ( MARKER : in MARKER_TYPE ) is -- ============================================================ -- Set the marker type for use when the corresponding ASF -- is INDIVIDUAL -- ANS GKS, section 5.4, page 91 -- Effect : The current marker type is set to the specified value. -- Marker types: -- 1 - dot -- 2 - plus sign -- 3 - asterisk -- 4 - circle -- 5 - diagonal cross -- >5 - implementation dependent -- ============================================================ STYLE_DATA : TERM_ACC.STYLE_RECORD ( MARKER_PATTERN ) ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_MARKERTYPE" ) ; end if ; -- load style_data STYLE_DATA.MARKER := MARKER ; TERM_ACC.SET_STYLE ( STYLE_DATA ) ; case MARKER is when 1 => POLYMARKER_TEXT := "." ; when 2 => POLYMARKER_TEXT := "+" ; when 3 => POLYMARKER_TEXT := "*" ; when 4 => POLYMARKER_TEXT := "O" ; when 5 => POLYMARKER_TEXT := "X" ; when others => null; end case ; -- MARKER end SET_MARKER_TYPE ; procedure SET_POLYLINE_COLOUR_INDEX ( COLOUR : in COLOUR_INDEX ) is -- ============================================================ -- Set the polyline colour index for use when the corresponding ASF -- is INDIVIDUAL -- ANS GKS, section 5.4, page 90 -- Effect : The current polyline colour index is set to the -- specified value. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_POLYLINE_COLOUR_INDEX" ) ; end if ; TERM_ACC.SET_COLOR_INDEX ( FOR_LINE_STYLE , COLOUR ) ; end SET_POLYLINE_COLOUR_INDEX ; procedure SET_POLYMARKER_COLOUR_INDEX ( COLOUR : in COLOUR_INDEX ) is -- ============================================================ -- Set the polymarker colour index for use when the corresponding -- ASF is INDIVIDUAL -- ANS GKS, section 5.4, page 92 -- Effect : The current polymarker colour index is set to the -- specified value. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_POLYMARKER_COLOR_INDEX" ) ; end if ; TERM_ACC.SET_COLOR_INDEX ( FOR_MARKERS , COLOUR ) ; end SET_POLYMARKER_COLOUR_INDEX ; procedure SET_TEXT_COLOUR_INDEX ( COLOUR : in COLOUR_INDEX ) is -- ============================================================ -- Set the text colour index for use when the corresponding -- ASF is INDIVIDUAL -- ANS GKS, section 5.4, page 94 -- Effect : The current text colour index is set to the -- specified value. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_TEXT_COLOUR_INDEX" ) ; end if ; TERM_ACC.SET_COLOR_INDEX ( FOR_CHARACTER , COLOUR ) ; end SET_TEXT_COLOUR_INDEX ; procedure SET_TEXT_FONT_AND_PRECISION ( FONT_PRECISION : in TEXT_FONT_PRECISION ) is -- ============================================================ -- Set the text font and precision for use when the -- corresponding ASF is INDIVIDUAL -- ANS GKS, section 5.4, page 94 -- Effect : The 'current text font and precision' entry in the -- GKS state list is set to the value specified by -- the parameter. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_TEXT_FONT_AND_PRECISION" ) ; end if ; TERM_ACC.SET_TEXT_PRECISION( FONT_PRECISION.PRECISION ) ; end SET_TEXT_FONT_AND_PRECISION ; procedure SET_TEXT_PATH ( PATH : in TEXT_PATH ) is -- ============================================================ -- Select the text path RIGHT, LEFT, UP, or DOWN -- ANS GKS, section 5.4, page 95 -- Effect : Set the text path of character strings to the specified -- values for all subsequent text output primitives until -- the values are reset by another call to this function. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_TEXT_PATH" ) ; end if ; TERM_ACC.SET_TEXT_PATH ( PATH ) ; end SET_TEXT_PATH ; procedure SET_WINDOW ( TRANSFORMATION : in TRANSFORMATION_NUMBER ; WINDOW_LIMITS : in WC.RECTANGLE_LIMITS ) is -- ============================================================ -- Set window in WC of a normalization transformation -- ANS GKS, section 5.5, page 107 -- Effect : Defines a window for the specified normalization -- transformation. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_WINDOW" ) ; end if ; -- Save current window boundaries and determine window height. GKS_STATE_LIST.CURRENT_WINDOW := WINDOW_LIMITS ; GKS_STATE_LIST.CURRENT_WINDOW_HEIGHT := GKS_STATE_LIST.CURRENT_WINDOW.Y.MAX - GKS_STATE_LIST.CURRENT_WINDOW.Y.MIN ; end SET_WINDOW ; procedure SET_WORKSTATION_VIEWPORT ( WS : in WS_ID ; WS_VIEWPORT_LIMITS : in DC.RECTANGLE_LIMITS ) is -- ============================================================ -- Set workstation viewport in DC -- ANS GKS, section 5.5, page 109 -- Effect : Specifies where on the workstation display the view -- of NDC space will appear. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_WORKSTATION_VIEWPORT" ) ; end if ; end SET_WORKSTATION_VIEWPORT ; procedure TEXT ( POSITION : in WC.POINT ; CHAR_STRING : in STRING ) is -- ============================================================ -- Generate a text string at the given position in WC -- ANS GKS, section 5.3, page 83 -- Effect : Generates the specified text string at the specified -- position. -- ============================================================ TEXT_DATA : TERM_ACC.OBJECT_DATA_RECORD ( FOR_TEXT ) ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.TEXT" ) ; end if ; -- fill text_data with text specific data TEXT_DATA.REFERENCE_POINT := POSITION ; TEXT_DATA.TEXT_LENGTH := CHAR_STRING'Last - CHAR_STRING'First + 1 ; TEXT_DATA.TEXT ( 1..TEXT_DATA.TEXT_LENGTH ) := CHAR_STRING ; TERM_ACC.DRAW ( TEXT_DATA ) ; end TEXT ; end LEVEL_0A ; package body LEVEL_0B is -- =============================================================== -- This package body implements the GKS Level 0B operations. -- =============================================================== procedure INITIALISE_LOCATOR ( WS : in WS_ID ; DEVICE : in DEVICE_NUMBER ; INITIAL_TRANSFORMATION : in TRANSFORMATION_NUMBER ; INITIAL_POSITION : in WC.POINT ; ECHO_AREA : in DC.RECTANGLE_LIMITS ; DATA_RECORD : in LOCATOR_DATA_RECORD ) is -- ============================================================ -- Initializes a device for the work station so that a request -- from the locator device can be made -- ANS GKS, section 5.7, page 119 -- Effect : Initializes a request on the specified locator device. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.INITIALIZE_LOCATOR" ) ; end if ; TERM_ACC.PLACE_CURSOR( INITIAL_POSITION ) ; exception when LOCATOR_INPUT_ERROR => raise GKS_ERROR_2501 ; when others => raise GKS_ERROR_2501 ; end INITIALISE_LOCATOR ; procedure REQUEST_LOCATOR ( WS : in WS_ID ; DEVICE : in DEVICE_NUMBER ; STATUS : out INPUT_STATUS ; TRANSFORMATION : out TRANSFORMATION_NUMBER ; POSITION : out WC.POINT ) is -- ============================================================ -- Request position in WC and normalization transformation number -- from a locator device -- ANS GKS, section 5.7, page 131 -- Effect : Perform a request on the specified locator device. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.REQUEST_LOCATOR" ) ; end if ; POSITION := TERM_ACC.REQUEST_LOCATOR( DEVICE ) ; exception when LOCATOR_INPUT_ERROR => raise GKS_ERROR_2501 ; when others => raise GKS_ERROR_2501 ; end REQUEST_LOCATOR ; end LEVEL_0B ; package body LEVEL_1A is -- =============================================================== -- This package body implements the GKS Level 1A operations. -- =============================================================== procedure CLOSE_SEGMENT is -- ============================================================ -- Segment construction finished -- ANS GKS, section 5.6, page 111 -- Effect : Close the currently open segment. Primitives may -- no longer be added to the closed segment. -- ============================================================ DUMMY_SEGMENT_ID : constant SEGMENT_NAME := 1 ; FINISH_SEGMENT : constant TERM_ACC. SEGMENT_OPERATIONS_TYPE := FINISH ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.CLOSE_SEGMENT" ) ; end if ; TERM_ACC.SEGMENT_OPERATION( FINISH_SEGMENT , DUMMY_SEGMENT_ID ) ; end CLOSE_SEGMENT ; procedure CREATE_SEGMENT ( SEGMENT : in SEGMENT_NAME ) is -- ============================================================ -- Create a segment and start constructing it -- ANS GKS, section 5.6, page 111 -- Effect : Create a segment. Subsequent calls to output primitive -- functions will place the primitives into the currently -- open segment. -- ============================================================ START_SEGMENT : constant TERM_ACC. SEGMENT_OPERATIONS_TYPE := START ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.CREATE_SEGMENT" ) ; end if ; TERM_ACC.SEGMENT_OPERATION( START_SEGMENT , SEGMENT ) ; end CREATE_SEGMENT ; procedure DELETE_SEGMENT ( SEGMENT : in SEGMENT_NAME ) is -- ============================================================ -- Delete a segment -- ANS GKS, section 5.6, page 112 -- Effect : Delete all copies of the specified segment stored in -- GKS. The segment name may be reused. -- ============================================================ DESTROY_SEGMENT : constant TERM_ACC. SEGMENT_OPERATIONS_TYPE := DESTROY ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.DELETE_SEGMENT" ) ; end if ; TERM_ACC.SEGMENT_OPERATION ( DESTROY_SEGMENT , SEGMENT ) ; end DELETE_SEGMENT ; procedure REDRAW_ALL_SEGMENTS_ON_WORKSTATION ( WS : in WS_ID ) is -- ============================================================ -- Redraw all visible segments stored on a workstation -- ANS GKS, section 5.2, page 77 -- Effect : For the specified workstation, all deferred actions are -- executed, the display surface is cleared if not empty, -- and all visible segments are displayed. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.REDRAW_ALL_SEGMENTS_ON_WKST" ) ; end if ; TERM_ACC.REDRAW_ALL_SEGMENTS ; end REDRAW_ALL_SEGMENTS_ON_WORKSTATION ; procedure RENAME_SEGMENT ( OLD_NAME : in SEGMENT_NAME ; NEW_NAME : in SEGMENT_NAME ) is -- ============================================================ -- Change name of a segment -- ANS GKS, section 5.6, page 111 -- Effect : Rename the specified segment. The old segment name -- may be reused. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.RENAME_SEGMENT" ) ; end if ; TERM_ACC.RENAME_SEGMENT ( OLD_NAME , NEW_NAME ) ; end RENAME_SEGMENT ; procedure SET_HIGHLIGHTING ( SEGMENT : in SEGMENT_NAME ; HIGHLIGHTING : in SEGMENT_HIGHLIGHTING ) is -- ============================================================ -- Mark segment normal or highlighted -- ANS GKS, section 5.6, page 116 -- Effect : Set the highlighting attribute to the value -- HIGHLIGHTED or NORMAL. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_HIGHLIGHTING" ) ; end if ; TERM_ACC.SET_HIGHLIGHTING ( SEGMENT, HIGHLIGHTING ) ; end SET_HIGHLIGHTING ; procedure SET_SEGMENT_PRIORITY ( SEGMENT : in SEGMENT_NAME ; PRIORITY : in SEGMENT_PRIORITY ) is -- ============================================================ -- Set priority of a segment -- ANS GKS, section 5.6, page 117 -- Effect : Set the priority of the specified segment to the specified -- priority. Priority is a value in the range 0 to 1. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_SEGMENT_PRIORITY" ) ; end if ; TERM_ACC.SET_SEGMENT_PRIORITY ( SEGMENT , PRIORITY ) ; end SET_SEGMENT_PRIORITY ; procedure SET_VISIBILITY ( SEGMENT : in SEGMENT_NAME ; VISIBILITY : in SEGMENT_VISIBILITY ) is -- ============================================================ -- Mark segment visible or invisible -- ANS GKS, section 5.6, page 116 -- Effect : Set the visibility attributes of the specified segment -- to VISIBLE or INVISIBLE. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_VISIBILITY" ) ; end if ; TERM_ACC.SET_VISIBILITY ( SEGMENT, VISIBILITY ) ; end SET_VISIBILITY ; end LEVEL_1A ; package body LEVEL_1B is -- =============================================================== -- This package body implements the GKS Level 1B operations. -- =============================================================== procedure REQUEST_PICK ( WS : in WS_ID ; DEVICE : in DEVICE_NUMBER ; STATUS : out PICK_REQUEST_STATUS ; SEGMENT : out SEGMENT_NAME ; PICK : out PICK_ID ) is -- ============================================================ -- Request segment name, pick identifier and pick status from a -- pick device -- ANS GKS5.7, section 5.7, page 134 -- Effect : Perform a request on the specified pick device. -- ============================================================ PICK_RECORD : PICK_DATA_RECORD ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.REQUEST_PICK" ) ; end if ; PICK_RECORD := TERM_ACC.REQUEST_PICK ( DEVICE ) ; STATUS := PICK_RECORD.PICK_STATUS ; SEGMENT := PICK_RECORD.PICK_SEGMENT ; PICK := PICK_RECORD.OBJECT_ID ; end REQUEST_PICK ; procedure SET_DETECTABILITY ( SEGMENT : in SEGMENT_NAME; DETECTABILITY : in SEGMENT_DETECTABILITY ) is -- ============================================================ -- Mark segment undetectable or detectable -- ANS GKS, section 5.6, page 117 -- Effect : Set the detectability attributes of the specified segment -- to DETECTABLE or UNDETECTABLE. -- ============================================================ begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( "GKS_PRIME.SET_DETECTABILITY" ) ; end if ; TERM_ACC.SET_DETECTABILITY ( SEGMENT, DETECTABILITY ) ; end SET_DETECTABILITY ; end LEVEL_1B ; begin null; exception when others => raise ; end GKS_PRIME ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --graphic_driver_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-02-10 09:04 by RAM with GRAPHICS_DATA ; use GRAPHICS_DATA ; with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; package GRAPHIC_DRIVER is -- ================================================================ -- -- This package provides all the necessary screen and graphic -- manipulation functions needed to perform editing of Graphic -- Ada Notation. -- -- Requirements: -- 1) draw graphical entities -- 2) erase graphical entities -- 3) move graphical entities -- 4) save and restore graphical entities -- 5) initialize the graphics device -- 6) restore the graphics device to VT-100 compatibility mode -- 7) provide a device and compiler independent interface -- -- This package is designed to perform the low level graphics -- functions associated with the Graphic Ada Designer, which -- will use on a VT-100 compatible bit-mapped graphics device. -- This package will be independent of the bit-mapped oriented -- characteristics of the actual terminal. This is accomplished -- by using the VIRTUAL_DISPLAY_INTERFACE (similar to that used by -- the GKS graphics system). Specific features of the VT-100 terminal -- will be supported by this package. -- -- The package needs to group symbols into hierarchies so that -- related symbols can be moved together (e.g., the name (label) -- of a package (box)). If the display list capability is -- utilized, it will be utilized to meet this requirement. -- -- ================================================================== package GRAPHICS renames GRAPHICS_DATA ; procedure CLEAR_MENU ( MENU : in GRAPHICS.SEGMENT_LIST_TYPE ) ; -- ====================================================== -- Clear the selected menu in the menu window. -- ====================================================== procedure CLOSE_SEGMENT ; -- =============================================================== -- Close the currently active drawing segment. -- ============================================================== procedure DELETE_SEGMENT ( SEGMENT : in GKS_SPECIFICATION.SEGMENT_NAME ) ; -- =============================================================== -- Delete a segment from the graphic output. -- ============================================================== procedure DISPLAY_MENU ( MENU : in GRAPHICS.SEGMENT_LIST_TYPE ) ; -- ====================================================== -- Display the selected menu in the menu window. -- ====================================================== procedure DRAW_ABORT_ICON ; -- ======================================================== -- Procedure draws the abort icon in the upper left corner -- of the graphics window. -- ======================================================== function DRAW_BOX ( COLOR : in GRAPHICS.COLOR_TYPE ; FILL : in GKS_SPECIFICATION.INTERIOR_STYLE ; LINE : in GRAPHICS.LINE_TYPE ; UPPER_LEFT : in GRAPHICS.POINT ; LOWER_RIGHT : in GRAPHICS.POINT ) return GKS_SPECIFICATION.SEGMENT_NAME ; -- ======================================================== -- Procedure draws a box of defined parameters, used for -- creating menus and icons only. -- ======================================================== function DRAW_FIGURE ( DRAWING_ENTITY : GRAPHICS.FIGURE_ENTITY ; BEGIN_POINT : GRAPHICS.POINT ; END_POINT : GRAPHICS.POINT ) return GKS_SPECIFICATION.SEGMENT_NAME ; -- ====================================================== -- Draw the specified graphic entity at the specified -- position using the currently defined attributes for -- the graphic entity, and return its SEGMENT_ID. -- ====================================================== function DRAW_LINE ( DRAWING_ENTITY : GRAPHICS.LINE_ENTITY ; STARTING_POINT : GRAPHICS.POINT ; ENDING_POINT : GRAPHICS.POINT ) return GKS_SPECIFICATION.SEGMENT_NAME ; -- ====================================================== -- Draw a line at the specified position using the -- currently defined attributes for the specified -- graphic entity, and return its SEGMENT_ID. -- ====================================================== function GET_GRAPHICS_CURSOR_POSITION return GRAPHICS.POINT ; -- ===================================================== -- Return the position of the graphics cursor in world -- coordinates. -- ===================================================== procedure GRAPHICS_SCREEN ( MODE : in MODE_TYPE ) ; -- ===================================================== -- Activates or Deactivates the visibility of the -- graphics screen. -- ===================================================== procedure HILITE_SEGMENT ( SEGMENT_ID : in GKS_SPECIFICATION.SEGMENT_NAME; MODE : in GKS_SPECIFICATION.SEGMENT_HIGHLIGHTING ) ; -- ====================================================== -- Turn the selected segment highlight on or off. -- ====================================================== procedure INITIALIZE_GRAPHICS_MODE ; -- ======================================================== -- Initialize device for graphics capability. -- ======================================================== procedure INIT_SCREEN ( NEW_COLOR : in GRAPHICS.COLOR_TYPE ; MENU_AREA : out GRAPHICS.RECTANGLE ) ; -- ======================================================== -- Set the screen parameters as needed. This will include -- establishing a scroll region on the bottom two lines. -- ======================================================== procedure LABEL ( SEGMENT_ID_NUM : out GKS_SPECIFICATION.SEGMENT_NAME ; SIZE : out GRAPHICS.POINT ; LOCATION : in GRAPHICS.POINT ; NAME : in String ; CHARACTER_COLOR : in GRAPHICS.COLOR_TYPE ; BACKGROUND_COLOR : in GRAPHICS.COLOR_TYPE := WHITE ) ; -- ====================================================== -- Place the specified label on the graph and associate it with -- the specified object, returning the label SEGMENT_ID. -- ====================================================== function LOCATION_IN_GRAPHIC_VIEWPORT ( COORDINATE : in GRAPHICS.POINT ) return Boolean ; -- ====================================================== -- Determins if the specified point is located in the -- current graphics viewport area. -- ====================================================== procedure MOVE ( SEGMENT_ID : in GKS_SPECIFICATION.SEGMENT_NAME ; NEW_LOCATION : in GRAPHICS.POINT ) ; -- ====================================================== -- Move the specified segment to its new location. -- ====================================================== function OPEN_SEGMENT return GKS_SPECIFICATION.SEGMENT_NAME ; -- =============================================================== -- Create and open a segment for graphic output. -- ============================================================== procedure PAN ( DIRECTION : in GRAPHICS.PAN_DIRECTION ) ; -- ====================================================== -- Pan away from the current display. -- ====================================================== procedure PAN_AND_ZOOM_DISPLAY ( MODE : in MODE_TYPE ) ; -- ====================================================== -- Display the Pan and Zoom relation view. -- ====================================================== function PARALLELOGRAM_POINTS ( UPPER_LEFT_PT : in GRAPHICS.POINT ; LOWER_RIGHT_PT : in GRAPHICS.POINT ; Y_VALUE : in GRAPHICS.WC ) return GRAPHICS.WC ; -- =================================================================== -- From the upper left and lower right points, and the stated Y -- location, determine the X location of a task entry point. -- =================================================================== function PICK_SEGMENT return GKS_SPECIFICATION.SEGMENT_NAME ; -- ====================================================== -- Ask the operator to pick a graphical object and return -- its SEGMENT_ID. -- ====================================================== procedure PLACE_CURSOR ( POSITION : in GRAPHICS.POINT ) ; -- =========================================================== -- This procedure places the graphics cursor at the specified -- location on the screen ; -- =========================================================== procedure PRINT_SCREEN ; -- =========================================================== -- This procedure prints the visible contents of the graphics -- viewport to the local terminal printer. -- =========================================================== procedure REFRESH_SCREEN ; -- ========================================================== -- This procedure rewrites the entire screen with -- the contents of the current window on the graphics -- page. This will be done using the display list -- capability. If the window has not yet been defined it -- will default to a window on (0,0) with scaling of 1. -- =========================================================== procedure SELECT_WINDOW ( WINDOW : in GRAPHICS.WINDOW_TYPE ) ; -- ============================================================= -- Set the currently active window. -- ============================================================= procedure SET_ABORT_CAPABILITY( ABORT_REQUEST : GRAPHICS.MODE_TYPE ) ; -- =================================================================== -- Set the abort capability on or off. If the abort capability is on -- all locator points returned from the terminal will be tested for -- an abort request. -- =================================================================== procedure SET_CHARACTER_SIZE_ATTRIBUTES ( HEIGHT : in GRAPHICS.WC ; WIDTH : in GRAPHICS.WC ; SPACING : in GRAPHICS.WC ; FONT : in GKS_SPECIFICATION.TEXT_PRECISION := GKS_SPECIFICATION.STROKE_PRECISION ) ; -- =================================================================== -- Set the character height, the character width, and the spacing -- between characters for subsequent graphic text output. -- =================================================================== procedure SET_DRAWING_PRIORITY ( PRIORITY : in PRIORITY_TYPE ) ; -- ====================================================== -- Set the visibile priority new segments. -- ====================================================== procedure SET_SEGMENT_VISIBILITY ( SEGMENT : in GKS_SPECIFICATION.SEGMENT_NAME ; MODE : in GKS_SPECIFICATION.SEGMENT_VISIBILITY ) ; -- ====================================================== -- Change the segment visibility. -- ====================================================== procedure TERMINATE_GRAPHICS_MODE ; -- ======================================================== -- Restore the device to VT100 mode. -- ======================================================== procedure UPDATE_COLOR_ATTRIBUTE ( DRAWING_ENTITY : in GRAPHICS.GRAPHIC_ENTITY ; NEW_COLOR : in GRAPHICS.COLOR_TYPE ) ; -- ====================================================== -- Update the value of the currently defined color -- attribute for the specified graphic entity. -- ====================================================== procedure UPDATE_LINE_ATTRIBUTE ( DRAWING_ENTITY : in GRAPHICS.GRAPHIC_ENTITY ; NEW_LINE : in GRAPHICS.LINE_TYPE ) ; -- ====================================================== -- Update the value of the currently defined line -- attribute for the specified graphic entity. -- ====================================================== procedure UPDATE_SHAPE_ATTRIBUTE ( DRAWING_ENTITY : in GRAPHICS.FIGURE_ENTITY ; NEW_SHAPE : in GRAPHICS.SHAPE_TYPE ) ; -- ====================================================== -- Update the value of the currently defined shape -- attribute for the specified graphic entity. -- ====================================================== procedure ZOOM ( DIRECTION : in GRAPHICS.ZOOM_DIRECTION ) ; -- ====================================================== -- Zoom in or out from the current display. -- ====================================================== --------------------------------------------------------- -- The following exceptions can be raised in this package: -- -- INVALID_SEGMENT_ID -- Raised if an illegal SEGMENT_ID is specified. -- INVALID_GRAPHICS_OPERATION -- Raised if an invalid, illegal, or unimplementable graphics -- operation is requested. -- INVALID_LOCATION -- Raised if an invalid location is specified for the graphing -- of an object. For example if a label is not placed on its -- associated object this exception will be raised. -- FIGURE_TOO_NARROW -- Raised if a figure requested to be drawn is too narrow in -- the x direction the minimum width is -- 2 * graphics_data.CHARACTER_WIDTH . ----------------------------------------------------------------- INVALID_SEGMENT_ID : exception ; INVALID_GRAPHICS_OPERATION : exception ; INVALID_LOCATION : exception ; FIGURE_TOO_NARROW : exception ; end GRAPHIC_DRIVER ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --graphic_driver_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-02-10 08:05 by RAM with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; with GKS_PRIME ; use GKS_PRIME ; with GKS_NON_STANDARD ; use GKS_NON_STANDARD ; with VIRTUAL_TERMINAL_INTERFACE ; use VIRTUAL_TERMINAL_INTERFACE ; with TRACE_PKG ; use TRACE_PKG ; with TEXT_IO ; use TEXT_IO ; package body GRAPHIC_DRIVER is -- ================================================================ -- -- This package provides all the necessary screen and graphic -- manipulation functions needed to perform editing of Graphic -- Ada Notation. -- -- Requirements: -- 1) draw graphical entities -- 2) erase graphical entities -- 3) move graphical entities -- 4) save and restore graphical entities -- 5) initialize the graphics device -- 6) restore the graphics device to VT-100 compatibility mode -- 7) provide a device and compiler independent interface -- -- This package is designed to perform the low level graphics -- functions associated with the Graphic Ada Designer, which -- will use a VT-100 compatible bit-mapped graphics device. -- This package will be independent of the bit-mapped oriented -- characteristics of the actual terminal. This is accomplished -- by using the VIRTUAL_DISPLAY_INTERFACE (similar to that used by -- the GKS graphics system). Specific features of the VT-100 terminal -- will be supported by this package. -- -- The package needs to group symbols into hierarchies so that -- related symbols can be moved together (e.g., the name (label) -- of a package (box)). If the display list capability is -- utilized, it will be utilized to meet this requirement. -- -- ================================================================== -------------------------------------- -- GKS package level short hand names -------------------------------------- package L_0A renames GKS_PRIME.LEVEL_0A ; package L_1A renames GKS_PRIME.LEVEL_1A ; package L_0B renames GKS_PRIME.LEVEL_0B ; package L_1B renames GKS_PRIME.LEVEL_1B ; package NON_STD renames GKS_NON_STANDARD.FROM_LEVEL_0A ; ------------------------------------------------------------------- -- Initialize the arrays containing the color representations -- and index number for each of the supported colors. ------------------------------------------------------------------- COLOR_REPRESENTATION : constant array( GRAPHICS.COLOR_TYPE ) of GKS_SPECIFICATION.COLOUR_REPRESENTATION := ( ORANGE => ( RED => 1.00, GREEN => 0.60, BLUE => 0.00 ), GREEN => ( RED => 0.00, GREEN => 0.74, BLUE => 0.00 ), YELLOW => ( RED => 1.00, GREEN => 1.00, BLUE => 0.00 ), VIOLET => ( RED => 0.74, GREEN => 0.60, BLUE => 0.87 ), RED => ( RED => 1.00, GREEN => 0.00, BLUE => 0.00 ), BLUE => ( RED => 0.00, GREEN => 0.00, BLUE => 1.00 ), BLACK => ( RED => 0.00, GREEN => 0.00, BLUE => 0.00 ), WHITE => ( RED => 0.87, GREEN => 0.87, BLUE => 0.87 ), BROWN => ( RED => 0.67, GREEN => 0.34, BLUE => 0.00 ), DARK_RED => ( RED => 0.80, GREEN => 0.00, BLUE => 0.00 ), CYAN => ( RED => 0.00, GREEN => 1.00, BLUE => 1.00 ), PINK => ( RED => 1.00, GREEN => 0.27, BLUE => 0.74 ), MAGENTA => ( RED => 1.00, GREEN => 0.00, BLUE => 1.00 ), PEACH => ( RED => 0.94, GREEN => 0.40, BLUE => 0.60 ), GRAY => ( RED => 0.67, GREEN => 0.67, BLUE => 0.67 ), DARK_PURPLE => ( RED => 0.47, GREEN => 0.07, BLUE => 0.47 )); COLOR_TO_INDEX : constant array( GRAPHICS.COLOR_TYPE ) of GKS_SPECIFICATION.COLOUR_INDEX := ( RED => 1 , GREEN => 2 , BLUE => 3 , ORANGE => 4 , YELLOW => 5 , VIOLET => 6 , BLACK => 7 , WHITE => 0 , BROWN => 9 , DARK_RED => 10 , CYAN => 11 , PINK => 12 , MAGENTA => 13 , PEACH => 14 , GRAY => 15 , DARK_PURPLE => 8 ) ; -------------------------------------------------------------- -- The current screen background color. -------------------------------------------------------------- CURRENT_BACKGROUND_COLOR : GRAPHICS.COLOR_TYPE ; -------------------------------------------------------------- -- The current text background color. -------------------------------------------------------------- CURRENT_TEXT_BACKGROUND_COLOR : GRAPHICS.COLOR_TYPE := GRAPHICS.CYAN ; -------------------------------------------------------------- -- The drawing segment priority. -------------------------------------------------------------- CURRENT_PRIORITY : PRIORITY_TYPE := 1.0 ; -------------------------------------------------------------- -- The scale factor currently in effect. -------------------------------------------------------------- SCALE_FACTOR : constant SCALE_FACTOR_TYPE := 8 ; --------------------------------------------------------------- -- Define the upper and lower bounds of the zoom and -- pan operations. --------------------------------------------------------------- RANGE_LOWER : constant INTEGER := 0; RANGE_UPPER : constant INTEGER := 2 * SCALE_FACTOR; --------------------------------------------------------------- -- Define the initial window size and the current window size -- of the current graphics display screen. --------------------------------------------------------------- INITIAL_WINDOW_SIZE : constant Integer := 8 ; -- range available (1..16) WINDOW_SIZE : Integer := INITIAL_WINDOW_SIZE; --------------------------------------------------------------- -- Define the translation factor from the window scale factor -- to the world coordinates. --------------------------------------------------------------- WINDOW_SCALE : constant GKS_SPECIFICATION.WC_TYPE := GKS_SPECIFICATION.WC_TYPE( GRAPHICS.WC'LAST / ( GRAPHICS.WC( 2 * SCALE_FACTOR ) ) ) ; --------------------------------------------------------------- -- Define the window to index id array. --------------------------------------------------------------- WINDOW_TO_INDEX : constant array ( GRAPHICS.WINDOW_TYPE ) of Natural := ( GRAPH_VIEW_PORT => 1 , MENU_VIEW_PORT => 2 , TEXT_VIEW_PORT => 0 ) ; --------------------------------------------------------------- -- Define a subtype of the allowable terminal types and the -- variable containing the active terminal type. --------------------------------------------------------------- subtype TERMINAL_TYPE is GKS_SPECIFICATION.WS_ID ; ACTIVE_TERMINAL : TERMINAL_TYPE := 1 ; --------------------------------------------------------------- -- Define variables required for subprogram call on GKS locator -- and pick functions. These variables are not required by -- the GRAPHIC_DRIVER program. --------------------------------------------------------------- WORK_STATION : GKS_SPECIFICATION.WS_ID := 1 ; DEVICE : GKS_SPECIFICATION.DEVICE_NUMBER := 1 ; TRANSFORM : GKS_SPECIFICATION.TRANSFORMATION_NUMBER := 1 ; CONNECTION : GKS_SPECIFICATION.CONNECTION_ID := "UNIT_1" ; STATION_TYPE : GKS_SPECIFICATION.WS_TYPE := 1 ; STATUS : GKS_SPECIFICATION.INPUT_STATUS ; ECHO_AREA : GKS_SPECIFICATION.DC.RECTANGLE_LIMITS ; LOCATOR_RECORD : GKS_SPECIFICATION.LOCATOR_DATA_RECORD ; PICK_RECORD : GKS_SPECIFICATION.PICK_DATA_RECORD ; --------------------------------------------------------------- -- Define the terminal space screen and window rectangles for -- the graphics and menu displays. -- GRAPHICS_SCREEN_RECTANGLE {constant} - rectangle in terminal -- screen space for the created graphics. -- MENU_SCREEN_RECTANGLE {constant} - rectangle in terminal screen -- space for the menu items. -- GRAPHIC_WINDOW_RECTANGLE {variable} - rectangle in terminal -- memory space for the created graphics window. -- Data for rectangle will be modified by PAN and ZOOM operations. -- MENU_WINDOW_RECTANGLE {constant} - rectangle in terminal memory -- space for the menu items window. -- WORLD_WINDOW_RECTANGLE {constant} - rectangle in terminal memory -- space to display the complete world view for pan and zoom. --------------------------------------------------------------- GRAPHICS_SCREEN_RECTANGLE : GKS_SPECIFICATION.WC.RECTANGLE_LIMITS := ( X => ( MIN => 6_144.0, MAX => 32_767.0 ), Y => ( MIN => 4_096.0, MAX => 32_767.0 ) ) ; MENU_SCREEN_RECTANGLE : GKS_SPECIFICATION.WC.RECTANGLE_LIMITS := ( X => ( MIN => 0.0, MAX => 6_144.0 ), Y => ( MIN => 4_096.0, MAX => 32_767.0 ) ) ; -- Initial max X & Y boundries are a function of the initial -- min X & Y boundries, scale factor, and the initial window size. INIT_MIN_X : constant GKS_SPECIFICATION.WC_TYPE := 2_048.0 ; INIT_MIN_Y : constant GKS_SPECIFICATION.WC_TYPE := 14_336.0 ; GRAPHIC_WINDOW_RECTANGLE : GKS_SPECIFICATION.WC.RECTANGLE_LIMITS := ( X => ( MIN => INIT_MIN_X , MAX => INIT_MIN_X + GKS_SPECIFICATION.WC_TYPE( INITIAL_WINDOW_SIZE ) * WINDOW_SCALE ) , Y => ( MIN => INIT_MIN_Y , MAX => INIT_MIN_Y + GKS_SPECIFICATION.WC_TYPE( INITIAL_WINDOW_SIZE ) * WINDOW_SCALE ) ) ; MENU_WINDOW_RECTANGLE : GKS_SPECIFICATION.WC.RECTANGLE_LIMITS := ( X => ( MIN => 0.0, MAX => 3_072.0 ), Y => ( MIN => 0.0, MAX => 10_752.0 )) ; WORLD_WINDOW_RECTANGLE : GKS_SPECIFICATION.WC.RECTANGLE_LIMITS := ( X => ( MIN => 0.0, MAX => 32_767.0 ), Y => ( MIN => 0.0, MAX => 32_767.0 )) ; --------------------------------------------------------------- -- Define x and y components of the reference point -- ( the upper left point of the display rectangle ) which -- positions the current graphics display screen. --------------------------------------------------------------- X_REF : INTEGER := INTEGER( GRAPHIC_WINDOW_RECTANGLE.X.MIN / WINDOW_SCALE ) ; Y_REF : INTEGER := INTEGER( GRAPHIC_WINDOW_RECTANGLE.Y.MAX / WINDOW_SCALE ) ; -------------------------------------------------------------- -- Define the rectangle encompassing the WC system. -------------------------------------------------------------- WC_WINDOW : constant GRAPHICS.RECTANGLE := ( X => ( MIN => GRAPHICS.WC'FIRST, MAX => GRAPHICS.WC'LAST ), Y => ( MIN => GRAPHICS.WC'FIRST, MAX => GRAPHICS.WC'LAST )) ; -------------------------------------------------------------- -- Define the segment number currently in effect. -------------------------------------------------------------- CURRENT_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME := GRAPHICS.NULL_SEGMENT + 1 ; -------------------------------------------------------------- -- Define the array which maintains an indication of -- segments currently in use. -------------------------------------------------------------- MAXIMUM_SEGMENT_NUMBER : constant GKS_SPECIFICATION.SEGMENT_NAME := 6000 ; SEGMENT_IS_USED : array( GKS_SPECIFICATION.SEGMENT_NAME range GRAPHICS.NULL_SEGMENT .. MAXIMUM_SEGMENT_NUMBER ) of BOOLEAN := ( TRUE, others => FALSE ) ; SEGMENT_SEARCH_INDEX : GKS_SPECIFICATION.SEGMENT_NAME := GRAPHICS.NULL_SEGMENT ; -------------------------------------------------------------- -- Boolean to determine if test for abort should be performed. -------------------------------------------------------------- ABORT_CAPABILITY_ACTIVE : boolean := FALSE ; -------------------------------------------------------------- -- Define the segment number of the abort icon -------------------------------------------------------------- ABORT_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME := GRAPHICS.NULL_SEGMENT ; -------------------------------------------------------------- -- Define the array containing the upper left and lower right -- points of the abort rectangle -------------------------------------------------------------- ABORT_POINTS : GKS_SPECIFICATION.WC.POINT_ARRAY(1..2); -------------------------------------------------------------- -- Define the pan and zoom view display segment. -------------------------------------------------------------- PAN_ZOOM_BOX : GKS_SPECIFICATION.SEGMENT_NAME ; -------------------------------------------------------------- -- Define the font type currently in use -------------------------------------------------------------- CURRENT_FONT : GKS_SPECIFICATION.TEXT_PRECISION := GKS_SPECIFICATION.CHAR_PRECISION ; -------------------------------------------------------------- -- Boolean indicating if segment is open or closed. -------------------------------------------------------------- SEGMENT_IS_OPEN : BOOLEAN := false ; -------------------------------------------------------------- -- Map the Graphics line types into the GKS line types. -------------------------------------------------------------- LINE_TYPE_ARRAY : constant array( GRAPHICS.LINE_TYPE ) of GKS_SPECIFICATION.LINE_TYPE := ( GRAPHICS.SOLID => GKS_SPECIFICATION.LINE_TYPE'(1), GRAPHICS.DASHED => GKS_SPECIFICATION.LINE_TYPE'(2), GRAPHICS.DOTTED => GKS_SPECIFICATION.LINE_TYPE'(3) ); procedure SET_LINE_TYPE_AND_COLOR ( REQ_LINE_TYPE : in GRAPHICS.LINE_TYPE; REQ_LINE_COLOR : in GRAPHICS.COLOR_TYPE ) is -- =================================================================== -- Set the GKS line type and line color to the specified values. -- =================================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ("GRAPHICS_DRIVER.SET_LINE_TYPE_AND_COLOR") ; end if ; -- Set current GKS line type to the specified value. L_0A.SET_LINE_TYPE( LINE_TYPE_ARRAY( REQ_LINE_TYPE )); -- Set current GKS line color to the specified value. L_0A.SET_POLYLINE_COLOUR_INDEX( COLOR_TO_INDEX ( REQ_LINE_COLOR )); end SET_LINE_TYPE_AND_COLOR; function PARALLELOGRAM_POINTS ( UPPER_LEFT_PT : in GRAPHICS.POINT ; LOWER_RIGHT_PT : in GRAPHICS.POINT ; Y_VALUE : in GRAPHICS.WC ) return GRAPHICS.WC is -- =================================================================== -- From the upper left and lower right points, and the stated Y -- location, determine the X location of a task entry point. -- =================================================================== M : FLOAT ; B : FLOAT ; DELTA_Y : FLOAT ; DELTA_X : FLOAT ; X_VALUE : GRAPHICS.WC ; LOWER_LEFT_PT : GRAPHICS.POINT ; NEW_UPPER_LEFT_PT : GRAPHICS.POINT := UPPER_LEFT_PT ; begin -- Determine the "slant" of the parallelogram from the -- containing rectangle. LOWER_LEFT_PT.X := NEW_UPPER_LEFT_PT.X ; LOWER_LEFT_PT.Y := LOWER_RIGHT_PT.Y ; DELTA_Y := FLOAT( NEW_UPPER_LEFT_PT.Y - LOWER_RIGHT_PT.Y ) ; DELTA_X := DELTA_Y / 3.0 ; NEW_UPPER_LEFT_PT.X := NEW_UPPER_LEFT_PT.X + GRAPHICS.WC( DELTA_X ) ; -- Determine the line equation ( Y = mX + b ) DELTA_X := FLOAT( NEW_UPPER_LEFT_PT.X - LOWER_LEFT_PT.X ) ; DELTA_Y := FLOAT( NEW_UPPER_LEFT_PT.Y - LOWER_LEFT_PT.Y ) ; -- If slope is infinite then return initial x value if GRAPHICS.WC( DELTA_X ) = 0 then X_VALUE := NEW_UPPER_LEFT_PT.X ; else -- Determine the line equation and the x value corresponding -- to the stated y value. M := DELTA_Y / DELTA_X ; B := FLOAT( NEW_UPPER_LEFT_PT.Y ) - ( M * FLOAT( NEW_UPPER_LEFT_PT.X ) ) ; X_VALUE := GRAPHICS.WC( ( FLOAT( Y_VALUE ) - B ) / M ) ; end if ; return X_VALUE ; end PARALLELOGRAM_POINTS ; procedure NEW_GRAPHICS_WINDOW is -- =================================================================== -- Define the new window onto the world coordinate space which will -- be displayed to the operator. This procedure is called by the -- PAN and ZOOM procedures. -- =================================================================== begin GRAPHIC_WINDOW_RECTANGLE.X.MIN := GKS_SPECIFICATION.WC_TYPE( X_REF ) * WINDOW_SCALE ; GRAPHIC_WINDOW_RECTANGLE.X.MAX := GKS_SPECIFICATION.WC_TYPE( X_REF + WINDOW_SIZE ) * WINDOW_SCALE ; GRAPHIC_WINDOW_RECTANGLE.Y.MIN := GKS_SPECIFICATION.WC_TYPE( Y_REF - WINDOW_SIZE ) * WINDOW_SCALE ; GRAPHIC_WINDOW_RECTANGLE.Y.MAX := GKS_SPECIFICATION.WC_TYPE( Y_REF ) * WINDOW_SCALE ; -- Set current window to graphic area. SELECT_WINDOW ( GRAPHICS.GRAPH_VIEW_PORT ) ; -- delete the old pan_and_zoom box HILITE_SEGMENT( PAN_ZOOM_BOX, NORMAL ) ; DELETE_SEGMENT( PAN_ZOOM_BOX ) ; -- Define the pan and zoom display box with the current view PAN_ZOOM_BOX := DRAW_BOX( BLACK, HOLLOW, SOLID, ( GRAPHICS.WC( GRAPHIC_WINDOW_RECTANGLE.X.MAX ), GRAPHICS.WC( GRAPHIC_WINDOW_RECTANGLE.Y.MIN )), ( GRAPHICS.WC( GRAPHIC_WINDOW_RECTANGLE.X.MIN ), GRAPHICS.WC( GRAPHIC_WINDOW_RECTANGLE.Y.MAX )) ) ; -- set the hilite on HILITE_SEGMENT( PAN_ZOOM_BOX, HIGHLIGHTED ) ; -- Set current window to menu area. SELECT_WINDOW ( GRAPHICS.MENU_VIEW_PORT ) ; end NEW_GRAPHICS_WINDOW ; procedure DISPLAY_ERROR ( DISPLAY_STRING : in STRING ) is -- ========================================================= -- This procedure displays the received string to the -- operator, waits for an operator acknowledgement, and -- clears the displayed line. -- ========================================================= BLANK_LINE : constant STRING := " " ; POSITION : GRAPHICS.POINT ; CONTINUE : constant STRING := " Press the cursor input device to continue "; begin -- display received string and continue message VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( DISPLAY_STRING, VIRTUAL_TERMINAL_INTERFACE.FORMAT_FUNCTION'( CENTER_A_LINE ), VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE( 23 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( CONTINUE, VIRTUAL_TERMINAL_INTERFACE.FORMAT_FUNCTION'( CENTER_A_LINE ), VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE( 24 )) ; -- wait for operator acknowledgement POSITION := GRAPHIC_DRIVER.GET_GRAPHICS_CURSOR_POSITION ; -- clear the messages VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , VIRTUAL_TERMINAL_INTERFACE.FORMAT_FUNCTION'( CLEAR_A_LINE ), VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE( 23 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , VIRTUAL_TERMINAL_INTERFACE.FORMAT_FUNCTION'( CLEAR_A_LINE ), VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE( 24 )) ; exception -- if the operator tried to abort, dont allow at this time when OPERATION_ABORTED_BY_OPERATOR => null ; -- propogate any other error when others => raise ; end DISPLAY_ERROR ; procedure CLEAR_MENU ( MENU : in GRAPHICS.SEGMENT_LIST_TYPE ) is -- =================================================================== -- Clear the selected menu in the menu window. -- =================================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ("GRAPHICS_DRIVER.CLEAR_MENU") ; end if ; for MENU_INDEX in MENU'range loop if MENU( MENU_INDEX ) /= GRAPHICS.NULL_SEGMENT then -- Set the MENU_SEGMENT invisible by calling the GKS -- SET_VISIBILITY procedure. L_1A.SET_VISIBILITY( MENU( MENU_INDEX ), GKS_SPECIFICATION.INVISIBLE ); -- Set the MENU_SEGMENT undetectable by calling the GKS -- SET_DETECTABILITY procedure. L_1B.SET_DETECTABILITY( MENU( MENU_INDEX ), GKS_SPECIFICATION.UNDETECTABLE ); end if ; end loop; end CLEAR_MENU ; procedure CLOSE_SEGMENT is -- =============================================================== -- Close the currently active drawing segment. -- ============================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.CLOSE_SEGMENT") ; end if ; -- Close the segment currently open in the GKS. L_1A.CLOSE_SEGMENT; SEGMENT_IS_OPEN := false; end CLOSE_SEGMENT ; procedure DELETE_SEGMENT ( SEGMENT : in GKS_SPECIFICATION.SEGMENT_NAME ) is -- =============================================================== -- Delete a segment from the graphic output. -- ============================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.DELETE_SEGMENT") ; end if ; -- Update the segment used array to show the segment is not in use. SEGMENT_IS_USED( SEGMENT ) := FALSE ; -- Delete the specified segment from the GKS. L_1A.DELETE_SEGMENT( SEGMENT ); -- Redraw the graphics area to cover delete flaws end DELETE_SEGMENT ; procedure DISPLAY_MENU ( MENU : in GRAPHICS.SEGMENT_LIST_TYPE ) is -- =================================================================== -- Display the selected menu in the menu window. -- =================================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.DISPLAY_MENU") ; end if ; for MENU_INDEX in MENU'range loop if MENU( MENU_INDEX ) /= GRAPHICS.NULL_SEGMENT then -- Set the MENU_SEGMENT visible by calling the GKS -- SET_VISIBILITY procedure. L_1A.SET_VISIBILITY( MENU( MENU_INDEX ) , GKS_SPECIFICATION.VISIBLE ); -- Set the MENU_SEGMENT detectable by calling the GKS -- SET_DETECTABILITY procedure. L_1B.SET_DETECTABILITY( MENU( MENU_INDEX ) , GKS_SPECIFICATION.DETECTABLE ); end if; end loop; end DISPLAY_MENU ; procedure DRAW_ABORT_ICON is -- ======================================================== -- Procedure draws the abort icon in the upper left corner -- of the graphics window. -- ======================================================== COLOR : constant GRAPHICS.COLOR_TYPE := GRAPHICS.RED ; FILL : constant GKS_SPECIFICATION.INTERIOR_STYLE := GKS_SPECIFICATION.SOLID ; LINE : constant GRAPHICS.LINE_TYPE := GRAPHICS.SOLID ; IDENTIFIER : constant GKS_SPECIFICATION.GDP_ID := GDP_RECTANGLE ; ABORT_LABEL : constant STRING := "ABORT"; COLOR_RECORD : GKS_SPECIFICATION.ESCAPE_RECORD ( GKS_SPECIFICATION.ALPHA_BACKGROUND ); TEXT_POINT : GKS_SPECIFICATION.WC.POINT ; SCREEN_HEIGHT : constant GRAPHICS.WC := GRAPHICS.WC( GRAPHIC_WINDOW_RECTANGLE.Y.MAX - GRAPHIC_WINDOW_RECTANGLE.Y.MIN ); CHAR_HEIGHT : constant GRAPHICS.WC := GRAPHICS.WC( FLOAT( SCREEN_HEIGHT ) * 0.015 ) ; CHAR_WIDTH : constant GRAPHICS.WC := GRAPHICS.WC( FLOAT( SCREEN_HEIGHT ) * 0.01 ) ; CHAR_SPACING : constant GRAPHICS.WC := GRAPHICS.WC( FLOAT( SCREEN_HEIGHT ) * 0.01 ) ; ICON_Y_SIZE : GKS_SPECIFICATION.WC_TYPE := GKS_SPECIFICATION.WC_TYPE( CHAR_HEIGHT * 2 ) ; ICON_X_SIZE : GKS_SPECIFICATION.WC_TYPE := GKS_SPECIFICATION.WC_TYPE( CHAR_WIDTH * 7 + CHAR_SPACING * 4 ) ; STORED_FONT : GKS_SPECIFICATION.TEXT_PRECISION ; begin -- DRAW_ABORT_ICON -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.DRAW_ABORT_ICON") ; end if ; -- Delete the current abort icon if ABORT_SEGMENT /= GRAPHICS.NULL_SEGMENT then DELETE_SEGMENT( ABORT_SEGMENT ) ; end if ; -- Open a new segment for the abort icon. ABORT_SEGMENT := OPEN_SEGMENT ; -- Set drawing parameters and point list. SET_LINE_TYPE_AND_COLOR ( LINE , COLOR ); L_0A.SET_FILL_AREA_COLOUR_INDEX( COLOR_TO_INDEX ( COLOR )); L_0A.SET_FILL_AREA_INTERIOR_STYLE ( FILL ) ; ABORT_POINTS( 1 ).X := GRAPHIC_WINDOW_RECTANGLE.X.MIN ; ABORT_POINTS( 1 ).Y := GRAPHIC_WINDOW_RECTANGLE.Y.MAX ; ABORT_POINTS( 2 ).X := GRAPHIC_WINDOW_RECTANGLE.X.MIN + ICON_X_SIZE ; ABORT_POINTS( 2 ).Y := GRAPHIC_WINDOW_RECTANGLE.Y.MAX - ICON_Y_SIZE ; -- draw the box NON_STD.GDP ( ABORT_POINTS, IDENTIFIER ) ; -- Set the text background to the abort fill color COLOR_RECORD.COLOUR := COLOR_TO_INDEX ( GRAPHICS.RED ) ; NON_STD.ESCAPE( GKS_SPECIFICATION.ALPHA_BACKGROUND , COLOR_RECORD ) ; -- Set current GKS text color to the specified value. L_0A.SET_TEXT_COLOUR_INDEX( COLOR_TO_INDEX( GRAPHICS.BLACK ) ) ; -- save the font in use STORED_FONT := CURRENT_FONT ; -- set the stroke param as current CURRENT_FONT := GKS_SPECIFICATION.STROKE_PRECISION ; -- Adjust the current text size attributes for the current window SET_CHARACTER_SIZE_ATTRIBUTES( CHAR_HEIGHT, CHAR_WIDTH, CHAR_SPACING, CURRENT_FONT ) ; -- Generate the ABORT text string inside the rectangle TEXT_POINT.X := ABORT_POINTS( 1 ).X + GKS_SPECIFICATION.WC_TYPE( CHAR_WIDTH ); TEXT_POINT.Y := ABORT_POINTS( 1 ).Y - ( ICON_Y_SIZE * 0.25 ) ; L_0A.TEXT( TEXT_POINT, ABORT_LABEL ); -- Adjust the current text size attributes to the default attributes. SET_CHARACTER_SIZE_ATTRIBUTES( GRAPHICS.DEFAULT_CHARACTER_HEIGHT, GRAPHICS.DEFAULT_CHARACTER_WIDTH, GRAPHICS.DEFAULT_CHARACTER_WIDTH_SPACING, STORED_FONT ) ; -- set text background color COLOR_RECORD.COLOUR := COLOR_TO_INDEX ( CURRENT_TEXT_BACKGROUND_COLOR ) ; NON_STD.ESCAPE( GKS_SPECIFICATION.ALPHA_BACKGROUND , COLOR_RECORD ) ; -- Close the currently open segment and set the segment invisible. CLOSE_SEGMENT ; L_1A.SET_VISIBILITY( ABORT_SEGMENT, GKS_SPECIFICATION.INVISIBLE ); end DRAW_ABORT_ICON ; function DRAW_BOX ( COLOR : in GRAPHICS.COLOR_TYPE ; FILL : in GKS_SPECIFICATION.INTERIOR_STYLE ; LINE : in GRAPHICS.LINE_TYPE ; UPPER_LEFT : in GRAPHICS.POINT ; LOWER_RIGHT : in GRAPHICS.POINT ) return GKS_SPECIFICATION.SEGMENT_NAME is -- ======================================================== -- Procedure draws a box of defined parameters, used for -- creating menus and icons only. -- ======================================================== SEGMENT_ID : GKS_SPECIFICATION.SEGMENT_NAME ; POINTS : GRAPHICS.POINT_LIST(1..2) ; GKS_POINTS : GKS_SPECIFICATION.WC.POINT_ARRAY(1..2); IDENTIFIER : constant GKS_SPECIFICATION.GDP_ID := GDP_RECTANGLE ; begin -- DRAW_BOX -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.DRAW_BOX") ; end if ; -- Open a new segment for the graphic entity. SEGMENT_ID := OPEN_SEGMENT ; -- Set drawing parameters and point list. SET_LINE_TYPE_AND_COLOR ( LINE , COLOR ); L_0A.SET_FILL_AREA_COLOUR_INDEX( COLOR_TO_INDEX ( COLOR )); L_0A.SET_FILL_AREA_INTERIOR_STYLE ( FILL ) ; -- Checks if a point is beyond the boundry limits, if so set the -- drawn point to the limit concerned. POINTS( 1 ) := UPPER_LEFT ; POINTS( 2 ) := LOWER_RIGHT ; -- verify limits of X boundries, correct if beyond. if UPPER_LEFT.X < WC_WINDOW.X.MIN then POINTS( 1 ).X := WC_WINDOW.X.MIN ; elsif UPPER_LEFT.X > WC_WINDOW.X.MAX then POINTS( 1 ).X := WC_WINDOW.X.MAX ; end if ; if LOWER_RIGHT.X < WC_WINDOW.X.MIN then POINTS( 2 ).X := WC_WINDOW.X.MIN ; elsif LOWER_RIGHT.X > WC_WINDOW.X.MAX then POINTS( 2 ).X := WC_WINDOW.X.MAX ; end if ; -- verify limits of Y boundries, correct if beyond. if UPPER_LEFT.Y < WC_WINDOW.Y.MIN then POINTS( 1 ).Y := WC_WINDOW.Y.MIN ; elsif UPPER_LEFT.Y > WC_WINDOW.Y.MAX then POINTS( 1 ).Y := WC_WINDOW.Y.MAX ; end if ; if LOWER_RIGHT.Y < WC_WINDOW.Y.MIN then POINTS( 2 ).Y := WC_WINDOW.Y.MIN ; elsif LOWER_RIGHT.Y > WC_WINDOW.Y.MAX then POINTS( 2 ).Y := WC_WINDOW.Y.MAX ; end if ; -- Convert the points to GKS required floating point types. for I in POINTS'range loop GKS_POINTS( I ).X := GKS_SPECIFICATION.WC_TYPE( POINTS( I ).X ) ; GKS_POINTS( I ).Y := GKS_SPECIFICATION.WC_TYPE( POINTS( I ).Y ) ; end loop ; -- draw the box NON_STD.GDP ( GKS_POINTS, IDENTIFIER ) ; -- Close the currently open segment. CLOSE_SEGMENT ; return SEGMENT_ID ; end DRAW_BOX ; function DRAW_FIGURE ( DRAWING_ENTITY : GRAPHICS.FIGURE_ENTITY ; BEGIN_POINT : GRAPHICS.POINT ; END_POINT : GRAPHICS.POINT ) return GKS_SPECIFICATION.SEGMENT_NAME is -- ====================================================== -- Draw the specified graphic entity at the specified -- position using the currently defined attributes for -- the graphic entity, and return its SEGMENT_ID. -- ====================================================== SEGMENT_ID : GKS_SPECIFICATION.SEGMENT_NAME ; -- defines the minimum entity figure width to be drawn MINIMUM_FIGURE_WIDTH : constant GRAPHICS.WC := 2 * GRAPHICS.CHARACTER_WIDTH_OFFSET ; -- Define variables containing the upper left and lower right -- x and y coordinates. UL_X , UL_Y , LR_X , LR_Y : GRAPHICS.WC ; -- Variables used to calculate the point lists. INITIAL_DELTA_X , DELTA_X , DELTA_Y : GRAPHICS.WC; -- Arrays containing the point list used to generate the figure. GENERAL_PTS : GRAPHICS.POINT_LIST( 1..5 ) ; STACKED_PTS : GRAPHICS.POINT_LIST( 1..8 ) ; OCTAGON_PTS : GKS_SPECIFICATION.WC.POINT_ARRAY( 1..9 ) ; -- Array containing the point list for the circle GDP. CIRCLE_PTS : GKS_SPECIFICATION.WC.POINT_ARRAY(1..2); -- Arrays containing the general and stacked point arrays -- following the GKS required type conversion GKS_GENERAL_PTS : GKS_SPECIFICATION.WC.POINT_ARRAY( 1..5 ) ; GKS_STACKED_PTS : GKS_SPECIFICATION.WC.POINT_ARRAY( 1..8 ) ; -- Line type and line color required for the figure. REQ_LINE_TYPE : GRAPHICS.LINE_TYPE; REQ_LINE_COLOR : GRAPHICS.COLOR_TYPE; -- implementation of body as octagon CIRCLE_IMPLEMENTATION_AS_OCTAGON : constant Boolean := true ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.DRAW_FIGURE") ; end if ; -- get the ititial delta x INITIAL_DELTA_X := END_POINT.X - BEGIN_POINT.X ; -- check that the minimum figure width is met if INITIAL_DELTA_X < MINIMUM_FIGURE_WIDTH then raise FIGURE_TOO_NARROW ; end if ; -- Open a new segment for the graphic entity. SEGMENT_ID := OPEN_SEGMENT ; -- Set current GKS line type to the value specified in -- GRAPHICS.ENTITY_LINE( DRAWING_ENTITY ). -- Set current GKS line color to the value specified in -- GRAPHICS.ENTITY_COLOR( DRAWING_ENTITY ) SET_LINE_TYPE_AND_COLOR ( GRAPHICS.ENTITY_LINE( DRAWING_ENTITY ), GRAPHICS.ENTITY_COLOR( DRAWING_ENTITY ) ); -- Generate a GKS point list from -- a) the specified STARTING_POINT and ENDING_POINT, and -- b) the figure specified in ENTITY_SHAPE( DRAWING_ENTITY ) -- initialize variables containing the upper left and lower right -- x and y coordinates. UL_X := BEGIN_POINT.X ; LR_X := END_POINT.X ; UL_Y := BEGIN_POINT.Y ; LR_Y := END_POINT.Y ; -- Generate the point list for the basic rectangle. GENERAL_PTS( 1 ).X := UL_X; GENERAL_PTS( 1 ).Y := UL_Y; GENERAL_PTS( 2 ).X := LR_X; GENERAL_PTS( 2 ).Y := UL_Y; GENERAL_PTS( 3 ).X := LR_X; GENERAL_PTS( 3 ).Y := LR_Y; GENERAL_PTS( 4 ).X := UL_X; GENERAL_PTS( 4 ).Y := LR_Y; GENERAL_PTS( 5 ).X := UL_X; GENERAL_PTS( 5 ).Y := UL_Y; case GRAPHICS.ENTITY_SHAPE( DRAWING_ENTITY ) is when SINGLE_RECTANGLE => null; when STACKED_RECTANGLE => -- Move the general point list to the stacked rectangle -- point list. STACKED_PTS(1..5) := GENERAL_PTS(1..5); -- Add the lines for the embedded rectangle to the point list. STACKED_PTS( 6 ).X := UL_X; STACKED_PTS( 6 ).Y := UL_Y - GRAPHICS.STACKED_SIZE; STACKED_PTS( 7 ).X := LR_X; STACKED_PTS( 7 ).Y := STACKED_PTS( 6 ).Y; STACKED_PTS( 8 ) := STACKED_PTS( 2 ); when PARALLELOGRAM => -- used for task rep -- Determine new point values to change the rectangle to a -- parallelogram and update the point list. -- calculate the offset to adjust the parallelogram -- in the x direction DELTA_X := PARALLELOGRAM_POINTS( GENERAL_PTS( 1 ), GENERAL_PTS( 3 ), GENERAL_PTS( 1 ).Y ) - UL_X ; -- check that the minimum figure width is met if ( MINIMUM_FIGURE_WIDTH + DELTA_X ) > INITIAL_DELTA_X then -- Close the currently open segment. CLOSE_SEGMENT ; raise FIGURE_TOO_NARROW ; end if ; -- increase the upper left x by the delta offset UL_X := UL_X + DELTA_X ; -- decrease the lower right x by the delta offset LR_X := LR_X - DELTA_X ; -- update upper left point for first and last point of polyline GENERAL_PTS( 1 ).X := UL_X; GENERAL_PTS( 5 ).X := UL_X; GENERAL_PTS( 3 ).X := LR_X; when SQUARE | CIRCLE => -- Update the rectangle point list into a list defining -- a square. if not CIRCLE_IMPLEMENTATION_AS_OCTAGON then DELTA_Y := UL_Y - LR_Y; DELTA_X := LR_X - UL_X; if DELTA_X < DELTA_Y then LR_Y := UL_Y - DELTA_X; GENERAL_PTS( 3 ).Y := LR_Y; GENERAL_PTS( 4 ).Y := LR_Y; else LR_X := UL_X + DELTA_Y; GENERAL_PTS( 2 ).X := LR_X; GENERAL_PTS( 3 ).X := LR_X; end if ; end if ; end case; -- Draw the line by calling the GKS POLYLINE procedure for -- the polygons, and the GKS GDP procedure for the circle. if GRAPHICS.ENTITY_SHAPE( DRAWING_ENTITY ) = CIRCLE then if CIRCLE_IMPLEMENTATION_AS_OCTAGON then declare X_REF : constant GRAPHICS.WC := GENERAL_PTS( 1 ).X ; Y_REF : constant GRAPHICS.WC := GENERAL_PTS( 1 ).Y ; X_8TH : constant GRAPHICS.WC := ( GENERAL_PTS( 3 ).X - GENERAL_PTS( 1 ).X ) / 8 ; Y_8TH : constant GRAPHICS.WC := ( GENERAL_PTS( 1 ).Y - GENERAL_PTS( 3 ).Y ) / 8 ; begin -- circle implementation as octagon OCTAGON_PTS( 1 ).X := GKS_SPECIFICATION.WC_TYPE( X_REF + (4 * X_8TH)) ; OCTAGON_PTS( 1 ).Y := GKS_SPECIFICATION.WC_TYPE( Y_REF - (0 * Y_8TH)) ; OCTAGON_PTS( 2 ).X := GKS_SPECIFICATION.WC_TYPE( X_REF + (7 * X_8TH)) ; OCTAGON_PTS( 2 ).Y := GKS_SPECIFICATION.WC_TYPE( Y_REF - (1 * Y_8TH)) ; OCTAGON_PTS( 3 ).X := GKS_SPECIFICATION.WC_TYPE( X_REF + (8 * X_8TH)) ; OCTAGON_PTS( 3 ).Y := GKS_SPECIFICATION.WC_TYPE( Y_REF - (4 * Y_8TH)) ; OCTAGON_PTS( 4 ).X := GKS_SPECIFICATION.WC_TYPE( X_REF + (7 * X_8TH)) ; OCTAGON_PTS( 4 ).Y := GKS_SPECIFICATION.WC_TYPE( Y_REF - (7 * Y_8TH)) ; OCTAGON_PTS( 5 ).X := GKS_SPECIFICATION.WC_TYPE( X_REF + (4 * X_8TH)) ; OCTAGON_PTS( 5 ).Y := GKS_SPECIFICATION.WC_TYPE( Y_REF - (8 * Y_8TH)) ; OCTAGON_PTS( 6 ).X := GKS_SPECIFICATION.WC_TYPE( X_REF + (1 * X_8TH)) ; OCTAGON_PTS( 6 ).Y := GKS_SPECIFICATION.WC_TYPE( Y_REF - (7 * Y_8TH)) ; OCTAGON_PTS( 7 ).X := GKS_SPECIFICATION.WC_TYPE( X_REF + (0 * X_8TH)) ; OCTAGON_PTS( 7 ).Y := GKS_SPECIFICATION.WC_TYPE( Y_REF - (4 * Y_8TH)) ; OCTAGON_PTS( 8 ).X := GKS_SPECIFICATION.WC_TYPE( X_REF + (1 * X_8TH)) ; OCTAGON_PTS( 8 ).Y := GKS_SPECIFICATION.WC_TYPE( Y_REF - (1 * Y_8TH)) ; OCTAGON_PTS( 9 ) := OCTAGON_PTS( 1 ) ; L_0A.POLYLINE( OCTAGON_PTS ) ; end ; -- circle implementation as octagon else CIRCLE_PTS( 1 ).X := GKS_SPECIFICATION.WC_TYPE( GENERAL_PTS( 1 ).X ); CIRCLE_PTS( 1 ).Y := GKS_SPECIFICATION.WC_TYPE( GENERAL_PTS( 1 ).Y ); CIRCLE_PTS( 2 ).X := GKS_SPECIFICATION.WC_TYPE( GENERAL_PTS( 3 ).X ); CIRCLE_PTS( 2 ).Y := GKS_SPECIFICATION.WC_TYPE( GENERAL_PTS( 3 ).Y ); NON_STD.GDP( CIRCLE_PTS, GKS_SPECIFICATION.GDP_CIRCLE ) ; end if ; elsif GRAPHICS.ENTITY_SHAPE( DRAWING_ENTITY ) = STACKED_RECTANGLE then -- when a task is represented by a chopped rectangle only -- or GRAPHICS.ENTITY_SHAPE( DRAWING_ENTITY ) = PARALLELOGRAM then for I in STACKED_PTS'range loop GKS_STACKED_PTS( I ).X := GKS_SPECIFICATION.WC_TYPE( STACKED_PTS( I ).X ) ; GKS_STACKED_PTS( I ).Y := GKS_SPECIFICATION.WC_TYPE( STACKED_PTS( I ).Y ) ; end loop ; L_0A.POLYLINE( GKS_STACKED_PTS ); else for I in GENERAL_PTS'range loop GKS_GENERAL_PTS( I ).X := GKS_SPECIFICATION.WC_TYPE( GENERAL_PTS( I ).X ) ; GKS_GENERAL_PTS( I ).Y := GKS_SPECIFICATION.WC_TYPE( GENERAL_PTS( I ).Y ) ; end loop ; L_0A.POLYLINE( GKS_GENERAL_PTS ); end if; -- Close the currently open segment. CLOSE_SEGMENT ; return SEGMENT_ID ; end DRAW_FIGURE ; function DRAW_LINE ( DRAWING_ENTITY : GRAPHICS.LINE_ENTITY ; STARTING_POINT : GRAPHICS.POINT ; ENDING_POINT : GRAPHICS.POINT ) return GKS_SPECIFICATION.SEGMENT_NAME is -- ====================================================== -- Draw a line at the specified position using the -- currently defined attributes for the specified -- graphic entity, and return its SEGMENT_ID. -- ====================================================== SEGMENT_ID : GKS_SPECIFICATION.SEGMENT_NAME ; -- Array containing the point list used to generate the figure. PTS : GRAPHICS.POINT_LIST (1..2); GKS_PTS : GKS_SPECIFICATION.WC.POINT_ARRAY (1..2); begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.DRAW_LINE") ; end if ; -- Open a new segment for the graphic entity. SEGMENT_ID := OPEN_SEGMENT ; -- Set current GKS line type to the value specified in -- ENTITY_LINE( DRAWING_ENTITY ). -- Set current GKS line color to the value specified in -- ENTITY_COLOR( DRAWING_ENTITY ) SET_LINE_TYPE_AND_COLOR ( GRAPHICS.ENTITY_LINE( DRAWING_ENTITY ), GRAPHICS.ENTITY_COLOR( DRAWING_ENTITY ) ); -- Generate a GKS point list from the specified STARTING_POINT -- and ENDING_POINT. PTS( 1 ).X := GRAPHICS.WC( STARTING_POINT.X ); PTS( 1 ).Y := GRAPHICS.WC( STARTING_POINT.Y ); PTS( 2 ).X := GRAPHICS.WC( ENDING_POINT.X ); PTS( 2 ).Y := GRAPHICS.WC( ENDING_POINT.Y ); -- Checks if a point is beyond the boundry limits, if so set the -- drawn point to the limit concerned. -- verify limits of X boundries, correct if beyond. if PTS( 1 ).X < WC_WINDOW.X.MIN then PTS( 1 ).X := WC_WINDOW.X.MIN ; elsif PTS( 1 ).X > WC_WINDOW.X.MAX then PTS( 1 ).X := WC_WINDOW.X.MAX ; end if ; if PTS( 2 ).X < WC_WINDOW.X.MIN then PTS( 2 ).X := WC_WINDOW.X.MIN ; elsif PTS( 2 ).X > WC_WINDOW.X.MAX then PTS( 2 ).X := WC_WINDOW.X.MAX ; end if ; -- verify limits of Y boundries, correct if beyond. if PTS( 1 ).Y < WC_WINDOW.Y.MIN then PTS( 1 ).Y := WC_WINDOW.Y.MIN ; elsif PTS( 1 ).Y > WC_WINDOW.Y.MAX then PTS( 1 ).Y := WC_WINDOW.Y.MAX ; end if ; if PTS( 2 ).Y < WC_WINDOW.Y.MIN then PTS( 2 ).Y := WC_WINDOW.Y.MIN ; elsif PTS( 2 ).Y > WC_WINDOW.Y.MAX then PTS( 2 ).Y := WC_WINDOW.Y.MAX ; end if ; -- Perform GKS required type conversion on the point list. for I in PTS'range loop GKS_PTS( I ).X := GKS_SPECIFICATION.WC_TYPE( PTS( I ).X ) ; GKS_PTS( I ).Y := GKS_SPECIFICATION.WC_TYPE( PTS( I ).Y ) ; end loop ; -- Draw the line by calling the GKS POLYLINE procedure. L_0A.POLYLINE( GKS_PTS ); -- Close the currently open segment. CLOSE_SEGMENT ; return SEGMENT_ID ; end DRAW_LINE ; function GET_GRAPHICS_CURSOR_POSITION return GRAPHICS.POINT is -- =================================================================== -- Return the position of the graphics cursor in world -- coordinates. -- =================================================================== POSITION : GRAPHICS.POINT ; GKS_POSITION : GKS_SPECIFICATION.WC.POINT ; VALID_POSITION : Boolean := False ; ERROR_MESSAGE : constant String := " INPUT ERROR for cursor, Please RE-TRY " ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.GET_GRAPHICS_CURSOR_POSITION") ; end if ; -- try three times max to get a valid position for TRY in 1..3 loop GET_VALID_POSITION : declare -- GET_VALID_POSITION begin -- GET_VALID_POSITION -- Initialize the GKS locator device, and -- retrieve cursor location from the GKS locator device. L_0B.REQUEST_LOCATOR( WORK_STATION, DEVICE, STATUS, TRANSFORM, GKS_POSITION ); VALID_POSITION := True ; exception -- GET_VALID_POSITION -- don't panic for three tries when others => case TRY is when 1 | 2 => -- clear crud from buffer and try again VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " " , VIRTUAL_TERMINAL_INTERFACE.FORMAT_FUNCTION' ( CLEAR_SCREEN ) , VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE ( 1 ) ) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( ERROR_MESSAGE , VIRTUAL_TERMINAL_INTERFACE.FORMAT_FUNCTION' ( CENTER_A_LINE ), VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE ( 23 ) ) ; when 3 => -- ok we tried now pass it on raise ; end case ; -- TRY end GET_VALID_POSITION ; exit when VALID_POSITION ; end loop ; -- TRY -- If abort capability was requested and specified location is -- within abort rectangle then raise the abort exception. if ABORT_CAPABILITY_ACTIVE and GKS_POSITION.X >= ABORT_POINTS( 1 ).X and GKS_POSITION.X <= ABORT_POINTS( 2 ).X and GKS_POSITION.Y <= ABORT_POINTS( 1 ).Y and GKS_POSITION.Y >= ABORT_POINTS( 2 ).Y then raise OPERATION_ABORTED_BY_OPERATOR ; end if ; -- Convert GKS floating point position to graphics integer position. POSITION.X := GRAPHICS.WC( GKS_POSITION.X ) ; POSITION.Y := GRAPHICS.WC( GKS_POSITION.Y ) ; return POSITION ; end GET_GRAPHICS_CURSOR_POSITION ; procedure GRAPHICS_SCREEN ( MODE : in MODE_TYPE ) is -- ===================================================== -- Activates or Deactivates the visibility of the -- graphics screen. -- ===================================================== ESC_RECORD : GKS_SPECIFICATION.ESCAPE_RECORD ( GKS_SPECIFICATION.GRAPHICS_VISIBILITY ); begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.GRAPHICS_SCREEN") ; end if ; ESC_RECORD.GRAPHICS_ON := ( MODE = ON ) ; NON_STD.ESCAPE( GKS_SPECIFICATION.GRAPHICS_VISIBILITY , ESC_RECORD ); end GRAPHICS_SCREEN ; procedure HILITE_SEGMENT ( SEGMENT_ID : in GKS_SPECIFICATION.SEGMENT_NAME; MODE : in GKS_SPECIFICATION.SEGMENT_HIGHLIGHTING ) is -- ====================================================== -- Turn the selected segment highlight on or off. -- ====================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.HILITE_SEGMENT") ; end if ; -- Set the specified segment to normal display or highlighted -- display by calling the GKS SET_HIGHLIGHTING procedure. L_1A.SET_HIGHLIGHTING ( GKS_SPECIFICATION.SEGMENT_NAME( SEGMENT_ID ), MODE ); end HILITE_SEGMENT ; procedure INITIALIZE_GRAPHICS_MODE is -- ======================================================== -- Initialize device for graphics capability. -- ======================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.INITIALIZE_GRAPHICS_MODE") ; end if ; -- Open the GKS. L_0A.OPEN_GKS( GKS_SPECIFICATION.DEFAULT_ERROR_FILE ) ; -- Open the workstation. L_0A.OPEN_WORKSTATION( ACTIVE_TERMINAL, CONNECTION, STATION_TYPE ) ; -- Define the color representations for each of the supported colors. for COLOR in GRAPHICS.COLOR_TYPE loop L_0A.SET_COLOUR_REPRESENTATION ( ACTIVE_TERMINAL , COLOR_TO_INDEX ( COLOR ) , COLOR_REPRESENTATION ( COLOR ) ) ; end loop; end INITIALIZE_GRAPHICS_MODE ; procedure INIT_SCREEN ( NEW_COLOR : in GRAPHICS.COLOR_TYPE ; MENU_AREA : out GRAPHICS.RECTANGLE ) is -- =================================================================== -- Set the screen parameters as needed. This will include -- establishing a scroll region on the bottom two lines. -- =================================================================== WINDOW_VIEWPORT_RECORD : GKS_SPECIFICATION.ESCAPE_RECORD ( GKS_SPECIFICATION.MAP_WINDOW_TO_VIEWPORT ); COLOR_RECORD : GKS_SPECIFICATION.ESCAPE_RECORD ( GKS_SPECIFICATION.GRAPHIC_BACKGROUND ); begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.INIT_SCREEN") ; end if ; -- Initialize the current background color to -- system default color from MMI CURRENT_BACKGROUND_COLOR := NEW_COLOR ; -- Initialize the screen color parameters -- set screen background color COLOR_RECORD.COLOUR := COLOR_TO_INDEX ( NEW_COLOR ) ; NON_STD.ESCAPE( GKS_SPECIFICATION.ALPHA_BACKGROUND , COLOR_RECORD ) ; NON_STD.ESCAPE( GKS_SPECIFICATION.GRAPHIC_BACKGROUND , COLOR_RECORD ) ; -- set text color COLOR_RECORD.COLOUR := COLOR_TO_INDEX ( COLOR_TYPE'( BLACK ) ) ; NON_STD.ESCAPE( GKS_SPECIFICATION.ALPHA_WRITING , COLOR_RECORD ) ; -- Initialize the terminal space window to view for the menu display. WINDOW_VIEWPORT_RECORD.VIEW_WINDOW_ID := WINDOW_TO_INDEX ( GRAPHICS.MENU_VIEW_PORT ) ; WINDOW_VIEWPORT_RECORD.VIEW_RECTANGLE := MENU_SCREEN_RECTANGLE ; WINDOW_VIEWPORT_RECORD.WINDOW_RECTANGLE := MENU_WINDOW_RECTANGLE ; NON_STD.ESCAPE( GKS_SPECIFICATION.MAP_WINDOW_TO_VIEWPORT , WINDOW_VIEWPORT_RECORD ) ; -- Initialize the terminal space window to view for the graphic display. L_0A.SET_WINDOW( GKS_SPECIFICATION.TRANSFORMATION_NUMBER( 1 ), GRAPHIC_WINDOW_RECTANGLE ) ; WINDOW_VIEWPORT_RECORD.VIEW_WINDOW_ID := WINDOW_TO_INDEX ( GRAPHICS.GRAPH_VIEW_PORT ) ; WINDOW_VIEWPORT_RECORD.VIEW_RECTANGLE := GRAPHICS_SCREEN_RECTANGLE ; WINDOW_VIEWPORT_RECORD.WINDOW_RECTANGLE := GRAPHIC_WINDOW_RECTANGLE ; NON_STD.ESCAPE( GKS_SPECIFICATION.MAP_WINDOW_TO_VIEWPORT , WINDOW_VIEWPORT_RECORD ) ; -- Clear bottom lines on screen. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE( " ", VIRTUAL_TERMINAL_INTERFACE.CLEAR_A_LINE, VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE'last - 1 ) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE( " ", VIRTUAL_TERMINAL_INTERFACE.CLEAR_A_LINE, VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE'last ) ; MENU_AREA.X.MIN := GRAPHICS.WC( MENU_WINDOW_RECTANGLE.X.MIN ) ; MENU_AREA.X.MAX := GRAPHICS.WC( MENU_WINDOW_RECTANGLE.X.MAX ) ; MENU_AREA.Y.MIN := GRAPHICS.WC( MENU_WINDOW_RECTANGLE.Y.MIN ) ; MENU_AREA.Y.MAX := GRAPHICS.WC( MENU_WINDOW_RECTANGLE.Y.MAX ) ; -- initialize the pan and zoom display box with the current view PAN_ZOOM_BOX := DRAW_BOX( BLACK, HOLLOW, SOLID, ( GRAPHICS.WC( GRAPHIC_WINDOW_RECTANGLE.X.MAX ), GRAPHICS.WC( GRAPHIC_WINDOW_RECTANGLE.Y.MIN )), ( GRAPHICS.WC( GRAPHIC_WINDOW_RECTANGLE.X.MIN ), GRAPHICS.WC( GRAPHIC_WINDOW_RECTANGLE.Y.MAX )) ) ; -- set visibility off SET_SEGMENT_VISIBILITY( PAN_ZOOM_BOX, GKS_SPECIFICATION.SEGMENT_VISIBILITY' ( INVISIBLE ) ) ; -- Generate a new abort rectangle DRAW_ABORT_ICON ; -- set text background color COLOR_RECORD.COLOUR := COLOR_TO_INDEX ( CURRENT_TEXT_BACKGROUND_COLOR ) ; NON_STD.ESCAPE( GKS_SPECIFICATION.ALPHA_BACKGROUND , COLOR_RECORD ) ; end INIT_SCREEN ; procedure LABEL ( SEGMENT_ID_NUM : out GKS_SPECIFICATION.SEGMENT_NAME ; SIZE : out GRAPHICS.POINT ; LOCATION : in GRAPHICS.POINT ; NAME : in String ; CHARACTER_COLOR : in GRAPHICS.COLOR_TYPE ; BACKGROUND_COLOR : in GRAPHICS.COLOR_TYPE := WHITE ) is -- =================================================================== -- Place the specified label on the graph and associate it with -- the specified object, returning the labels SEGMENT_ID. -- =================================================================== CHECKED_LOCATION, MAGNITUDE : GRAPHICS.POINT ; GKS_LOCATION : GKS_SPECIFICATION.WC.POINT ; COLOR_RECORD : GKS_SPECIFICATION.ESCAPE_RECORD ( GKS_SPECIFICATION.GRAPHIC_BACKGROUND ); begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.LABEL") ; end if ; -- Open a new segment for the graphic entity. SEGMENT_ID_NUM := OPEN_SEGMENT ; -- calc the size point of the label ( lower right corner ) -- and store for constraint check MAGNITUDE.X := CHARACTER_WIDTH_OFFSET * NAME'length ; MAGNITUDE.Y := DEFAULT_CHARACTER_HEIGHT ; -- Checks if a point is beyond the boundry limits, if so set the -- drawn point to the limit concerned. CHECKED_LOCATION := LOCATION ; -- verify limits of X boundries, correct if beyond. if LOCATION.X + MAGNITUDE.X < WC_WINDOW.X.MIN then SIZE.X := WC_WINDOW.X.MIN ; elsif LOCATION.X + MAGNITUDE.X > WC_WINDOW.X.MAX then SIZE.X := WC_WINDOW.X.MAX ; else SIZE.X := LOCATION.X + MAGNITUDE.X ; end if ; if CHECKED_LOCATION.X < WC_WINDOW.X.MIN then CHECKED_LOCATION.X := WC_WINDOW.X.MIN ; elsif CHECKED_LOCATION.X > WC_WINDOW.X.MAX then CHECKED_LOCATION.X := WC_WINDOW.X.MAX ; end if ; -- verify limits of Y boundries, correct if beyond. if LOCATION.Y - MAGNITUDE.Y < WC_WINDOW.Y.MIN then SIZE.Y := WC_WINDOW.Y.MIN ; elsif LOCATION.Y - MAGNITUDE.Y > WC_WINDOW.Y.MAX then SIZE.Y := WC_WINDOW.Y.MAX ; else SIZE.Y := LOCATION.Y - MAGNITUDE.Y ; end if ; if CHECKED_LOCATION.Y < WC_WINDOW.Y.MIN then CHECKED_LOCATION.Y := WC_WINDOW.Y.MIN ; elsif CHECKED_LOCATION.Y > WC_WINDOW.Y.MAX then CHECKED_LOCATION.Y := WC_WINDOW.Y.MAX ; end if ; -- Set current GKS text color to the specified value. L_0A.SET_TEXT_COLOUR_INDEX( COLOR_TO_INDEX( CHARACTER_COLOR ) ) ; -- Temporarily set current GKS background color to the specified value. if BACKGROUND_COLOR /= CURRENT_BACKGROUND_COLOR then COLOR_RECORD.COLOUR := COLOR_TO_INDEX( BACKGROUND_COLOR ) ; NON_STD.ESCAPE( GKS_SPECIFICATION.GRAPHIC_BACKGROUND , COLOR_RECORD ) ; end if ; -- Generate the specified NAME at the specified LOCATION by -- calling the GKS TEXT procedure. GKS_LOCATION.X := GKS_SPECIFICATION.WC_TYPE( CHECKED_LOCATION.X ) ; GKS_LOCATION.Y := GKS_SPECIFICATION.WC_TYPE( CHECKED_LOCATION.Y ) ; L_0A.TEXT( GKS_LOCATION, NAME ); -- Close the currently open segment. CLOSE_SEGMENT ; -- Set current GKS background color back to its default value. if BACKGROUND_COLOR /= CURRENT_BACKGROUND_COLOR then COLOR_RECORD.COLOUR := COLOR_TO_INDEX( CURRENT_BACKGROUND_COLOR ) ; NON_STD.ESCAPE( GKS_SPECIFICATION.GRAPHIC_BACKGROUND , COLOR_RECORD ) ; end if ; end LABEL ; function LOCATION_IN_GRAPHIC_VIEWPORT ( COORDINATE : in GRAPHICS.POINT ) return Boolean is -- ====================================================== -- Determines if the specified point is located in the -- current graphics viewport area. -- ====================================================== begin return ( ( GKS_SPECIFICATION.WC_TYPE( COORDINATE.X ) <= GRAPHIC_WINDOW_RECTANGLE.X.MAX ) and ( GKS_SPECIFICATION.WC_TYPE( COORDINATE.X ) >= GRAPHIC_WINDOW_RECTANGLE.X.MIN ) and ( GKS_SPECIFICATION.WC_TYPE( COORDINATE.Y ) <= GRAPHIC_WINDOW_RECTANGLE.Y.MAX ) and ( GKS_SPECIFICATION.WC_TYPE( COORDINATE.Y ) >= GRAPHIC_WINDOW_RECTANGLE.Y.MIN ) ) ; end LOCATION_IN_GRAPHIC_VIEWPORT ; procedure MOVE ( SEGMENT_ID : in GKS_SPECIFICATION.SEGMENT_NAME ; NEW_LOCATION : in GRAPHICS.POINT ) is -- ====================================================== -- Move the specified segment to its new location. -- ====================================================== SPECIFIED_LOCATION : GRAPHICS.POINT := NEW_LOCATION ; ESC_RECORD : GKS_SPECIFICATION.ESCAPE_RECORD( GKS_SPECIFICATION.SEGMENT_MOVEMENT ); begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.MOVE") ; end if ; -- Perform a segment move by calling the GKS ESCAPE procedure -- with an escape function identifer of segment move. ESC_RECORD.SEGMENT := SEGMENT_ID ; -- Checks if a point is beyond the boundry limits, if so set the -- drawn point to the limit concerned. -- verify limits of X boundries, correct if beyond. if NEW_LOCATION.X < WC_WINDOW.X.MIN then SPECIFIED_LOCATION.X := WC_WINDOW.X.MIN ; elsif NEW_LOCATION.X > WC_WINDOW.X.MAX then SPECIFIED_LOCATION.X := WC_WINDOW.X.MAX ; end if ; -- verify limits of Y boundries, correct if beyond. if NEW_LOCATION.Y < WC_WINDOW.Y.MIN then SPECIFIED_LOCATION.Y := WC_WINDOW.Y.MIN ; elsif NEW_LOCATION.Y > WC_WINDOW.Y.MAX then SPECIFIED_LOCATION.Y := WC_WINDOW.Y.MAX ; end if ; ESC_RECORD.POSITION.X := GKS_SPECIFICATION.WC_TYPE( SPECIFIED_LOCATION.X ) ; ESC_RECORD.POSITION.Y := GKS_SPECIFICATION.WC_TYPE( SPECIFIED_LOCATION.Y ) ; NON_STD.ESCAPE( GKS_SPECIFICATION.SEGMENT_MOVEMENT, ESC_RECORD ); -- Redraw the graphics area to cover move flaws REFRESH_SCREEN ; end MOVE ; function OPEN_SEGMENT return GKS_SPECIFICATION.SEGMENT_NAME is -- =================================================================== -- Create and open a segment for graphic output. -- =================================================================== type LOOP_ID_TYPE is ( LOOP_1, LOOP_2 ) ; LOOP_ID : LOOP_ID_TYPE := LOOP_1 ; FOUND_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME := GRAPHICS.NULL_SEGMENT ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.OPEN_SEGMENT") ; end if ; -- If a segment is currently open then close the segment. if SEGMENT_IS_OPEN then CLOSE_SEGMENT; end if; -- Loop until an available segment is found; if no segment is -- available then raise the segments exhaused exception. loop if SEGMENT_IS_USED( SEGMENT_SEARCH_INDEX ) = FALSE then FOUND_SEGMENT := SEGMENT_SEARCH_INDEX ; SEGMENT_IS_USED( SEGMENT_SEARCH_INDEX ) := TRUE ; exit ; else if SEGMENT_SEARCH_INDEX >= MAXIMUM_SEGMENT_NUMBER then if LOOP_ID = LOOP_1 then SEGMENT_SEARCH_INDEX := GRAPHICS.NULL_SEGMENT ; LOOP_ID := LOOP_2 ; else DISPLAY_ERROR ( " UNABLE TO CONTINUE - segment supply exhausted " ) ; raise GRAPHICS.AVAILABLE_SEGMENTS_EXHAUSTED ; end if ; else SEGMENT_SEARCH_INDEX := SEGMENT_SEARCH_INDEX + 1 ; end if ; end if ; end loop ; CURRENT_SEGMENT := FOUND_SEGMENT ; if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("SEGMENT # = " & GKS_SPECIFICATION.SEGMENT_NAME'IMAGE(CURRENT_SEGMENT)) ; TRACE_PKG.TRACE(" ") ; end if ; -- Open a segment in the GKS with a segment identifier equal to -- the CURRENT_SEGMENT. L_1A.CREATE_SEGMENT( GKS_SPECIFICATION.SEGMENT_NAME( CURRENT_SEGMENT )) ; if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.OPEN_SEGMENT.END PROCEDURE") ; end if ; return CURRENT_SEGMENT ; end OPEN_SEGMENT ; procedure PAN ( DIRECTION : in GRAPHICS.PAN_DIRECTION ) is -- ====================================================== -- Pan away from the current display. -- ====================================================== NEW_WINDOW : BOOLEAN := false; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.PAN") ; end if ; -- Move the reference point associated with the current display -- as a function of the requested pan direction. Prior to -- performing the reference point update verify that the pan -- movement can be performed. case DIRECTION is when PAN_LEFT => -- If the current display can be moved then -- move the display by updating the x component of -- the reference point. if X_REF > RANGE_LOWER then X_REF := X_REF - 1; NEW_WINDOW := true; end if; when PAN_RIGHT => -- If the current display can be moved then -- move the display by updating the x component of -- the reference point. if ( X_REF + WINDOW_SIZE ) < RANGE_UPPER then X_REF := X_REF + 1; NEW_WINDOW := true; end if; when PAN_UP => -- If the current display can be moved then -- move the display by updating the y component of -- the reference point. if Y_REF < RANGE_UPPER then Y_REF := Y_REF + 1; NEW_WINDOW := true; end if; when PAN_DOWN => -- If the current display can be moved then -- move the display by updating the y component of -- the reference point. if ( Y_REF - WINDOW_SIZE ) > RANGE_LOWER then Y_REF := Y_REF - 1; NEW_WINDOW := true; end if; when MAX_PAN_LEFT => -- If the current display can be moved then -- move the display by updating the x component of -- the reference point. if X_REF > RANGE_LOWER then X_REF := RANGE_LOWER ; NEW_WINDOW := true; end if; when MAX_PAN_RIGHT => -- If the current display can be moved then -- move the display by updating the x component of -- the reference point. if ( X_REF + WINDOW_SIZE ) < RANGE_UPPER then X_REF := RANGE_UPPER - WINDOW_SIZE ; NEW_WINDOW := true; end if; when MAX_PAN_UP => -- If the current display can be moved then -- move the display by updating the y component of -- the reference point. if Y_REF < RANGE_UPPER then Y_REF := RANGE_UPPER ; NEW_WINDOW := true; end if; when MAX_PAN_DOWN => -- If the current display can be moved then -- move the display by updating the y component of -- the reference point. if ( Y_REF - WINDOW_SIZE ) > RANGE_LOWER then Y_REF := WINDOW_SIZE + RANGE_LOWER ; NEW_WINDOW := true; end if; end case; -- If the pan movement can be performed then generate a -- point list defining the new display area from the x and -- y components of the reference point and the current -- window size. if NEW_WINDOW then -- Perform a pan move by calling the GKS ESCAPE procedure -- with an escape function identifer of SET_TERMINAL_WINDOW NEW_GRAPHICS_WINDOW ; -- If window cannot be drawn notify the operator else DISPLAY_ERROR( " current window is on display boundary " ) ; end if; end PAN; procedure PAN_AND_ZOOM_DISPLAY ( MODE : in MODE_TYPE ) is -- ====================================================== -- Display the Pan and Zoom relation view. -- ====================================================== WINDOW_VIEWPORT_RECORD : GKS_SPECIFICATION.ESCAPE_RECORD ( GKS_SPECIFICATION.MAP_WINDOW_TO_VIEWPORT ); WINDOW_SELECT_RECORD : GKS_SPECIFICATION.ESCAPE_RECORD ( GKS_SPECIFICATION.SELECT_WINDOW ); begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.PAN_AND_ZOOM_DISPLAY") ; end if ; -- Set current window to graphic area. SELECT_WINDOW ( GRAPHICS.GRAPH_VIEW_PORT ) ; -- Initialize the terminal space window to view for the graphic display. WINDOW_VIEWPORT_RECORD.VIEW_WINDOW_ID := WINDOW_TO_INDEX ( GRAPHICS.GRAPH_VIEW_PORT ) ; WINDOW_VIEWPORT_RECORD.VIEW_RECTANGLE := GRAPHICS_SCREEN_RECTANGLE ; case MODE is when ON => -- Set up the pan and zoom display with the -- full world coordinate system in view and -- the current view bounded by a hilited box. -- set graphic viewport to full wc system WINDOW_VIEWPORT_RECORD.WINDOW_RECTANGLE := WORLD_WINDOW_RECTANGLE ; NON_STD.ESCAPE( GKS_SPECIFICATION.MAP_WINDOW_TO_VIEWPORT , WINDOW_VIEWPORT_RECORD ) ; -- display pan_and_zoom box in hilited color -- set visibility on SET_SEGMENT_VISIBILITY( PAN_ZOOM_BOX, GKS_SPECIFICATION.SEGMENT_VISIBILITY' ( VISIBLE ) ) ; -- set the hilite on HILITE_SEGMENT( PAN_ZOOM_BOX, HIGHLIGHTED ) ; when OFF => -- Set the graphic viewport to the current -- pan zoom selection. -- set pan_and_zoom box invisible -- set the hilite off HILITE_SEGMENT( PAN_ZOOM_BOX, NORMAL ) ; -- set visibility off SET_SEGMENT_VISIBILITY( PAN_ZOOM_BOX, GKS_SPECIFICATION.INVISIBLE ) ; -- return graphics viewport to current view setting L_0A.SET_WINDOW( GKS_SPECIFICATION.TRANSFORMATION_NUMBER( 1 ), GRAPHIC_WINDOW_RECTANGLE ) ; WINDOW_VIEWPORT_RECORD.WINDOW_RECTANGLE := GRAPHIC_WINDOW_RECTANGLE ; NON_STD.ESCAPE( GKS_SPECIFICATION.MAP_WINDOW_TO_VIEWPORT , WINDOW_VIEWPORT_RECORD ) ; -- Generate a new abort rectangle DRAW_ABORT_ICON ; end case ; -- MODE -- Redraw the graphics area to cover flaws --- REFRESH_SCREEN ; -- Set current window to menu area. SELECT_WINDOW ( GRAPHICS.MENU_VIEW_PORT ) ; end PAN_AND_ZOOM_DISPLAY ; function PICK_SEGMENT return GKS_SPECIFICATION.SEGMENT_NAME is -- =================================================================== -- Ask the operator to pick a graphical object and return its -- SEGMENT_ID. -- =================================================================== SEGMENT_ID : GKS_SPECIFICATION.SEGMENT_NAME ; PICK_STATUS : GKS_SPECIFICATION.PICK_REQUEST_STATUS ; PICKED_OBJECT : GKS_SPECIFICATION.PICK_ID ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.PICK_SEGMENT") ; end if ; -- Initialize the GKS pick device; -- retrieve the segment identifier from the GKS pick device. L_1B.REQUEST_PICK( WORK_STATION, DEVICE, PICK_STATUS, SEGMENT_ID, PICKED_OBJECT ) ; return SEGMENT_ID ; end PICK_SEGMENT ; procedure PLACE_CURSOR ( POSITION : in GRAPHICS.POINT ) is -- =========================================================== -- This procedure places the graphics cursor at the specified -- location on the screen ; -- =========================================================== GKS_POSITION : GKS_SPECIFICATION.WC.POINT ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHIC_DRIVER.PLACE_CURSOR") ; end if ; GKS_POSITION.X := GKS_SPECIFICATION.WC_TYPE( POSITION.X ) ; GKS_POSITION.Y := GKS_SPECIFICATION.WC_TYPE( POSITION.Y ) ; L_0B.INITIALISE_LOCATOR( WORK_STATION, DEVICE, TRANSFORM, GKS_POSITION, ECHO_AREA, LOCATOR_RECORD ) ; end PLACE_CURSOR ; procedure PRINT_SCREEN is -- ========================================================== -- This procedure prints the visible contents of the graphics -- viewport to the local terminal printer. -- =========================================================== PRINT_RECORD : GKS_SPECIFICATION.ESCAPE_RECORD( PRINT_WINDOW ) ; WINDOW_VIEWPORT_RECORD : GKS_SPECIFICATION.ESCAPE_RECORD ( GKS_SPECIFICATION.MAP_WINDOW_TO_VIEWPORT ); PRINT_SCREEN_RECTANGLE : GKS_SPECIFICATION.WC.RECTANGLE_LIMITS := ( X => ( MIN => 1_170.0, MAX => 31_597.0 ), Y => ( MIN => 1.0, MAX => 32_767.0 ) ) ; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.PRINT_SCREEN") ; end if ; -- set the window to print PRINT_RECORD.WINDOW := WINDOW_TO_INDEX( GRAPH_VIEW_PORT ) ; -- set the current viewport to graphics SELECT_WINDOW ( GRAPH_VIEW_PORT ) ; -- redefine graphics viewport to full size without altering -- aspect ratio WINDOW_VIEWPORT_RECORD.VIEW_WINDOW_ID := WINDOW_TO_INDEX ( GRAPHICS.GRAPH_VIEW_PORT ) ; WINDOW_VIEWPORT_RECORD.VIEW_RECTANGLE := PRINT_SCREEN_RECTANGLE ; WINDOW_VIEWPORT_RECORD.WINDOW_RECTANGLE := GRAPHIC_WINDOW_RECTANGLE ; NON_STD.ESCAPE( GKS_SPECIFICATION.MAP_WINDOW_TO_VIEWPORT , WINDOW_VIEWPORT_RECORD ) ; -- print the viewport contents NON_STD.ESCAPE( GKS_SPECIFICATION.PRINT_WINDOW, PRINT_RECORD ) ; -- redefine graphics viewport to predefined size WINDOW_VIEWPORT_RECORD.VIEW_WINDOW_ID := WINDOW_TO_INDEX ( GRAPHICS.GRAPH_VIEW_PORT ) ; WINDOW_VIEWPORT_RECORD.VIEW_RECTANGLE := GRAPHICS_SCREEN_RECTANGLE ; WINDOW_VIEWPORT_RECORD.WINDOW_RECTANGLE := GRAPHIC_WINDOW_RECTANGLE ; NON_STD.ESCAPE( GKS_SPECIFICATION.MAP_WINDOW_TO_VIEWPORT , WINDOW_VIEWPORT_RECORD ) ; -- redraw the graphics viewport REFRESH_SCREEN ; -- set the current viewport back to menu SELECT_WINDOW ( MENU_VIEW_PORT ) ; -- redraw the menu viewport REFRESH_SCREEN ; end PRINT_SCREEN ; procedure REFRESH_SCREEN is -- =================================================================== -- This procedure rewrites the entire screen with -- the contents of the current window on the graphics -- page. -- =================================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.REFRESH_SCREEN") ; end if ; -- Redraw all visible segments by calling the GKS -- REDRAW_ALL_SEGMENTS_ON_WORKSTATION procedure. L_1A.REDRAW_ALL_SEGMENTS_ON_WORKSTATION( ACTIVE_TERMINAL ) ; end REFRESH_SCREEN ; procedure SELECT_WINDOW ( WINDOW : in GRAPHICS.WINDOW_TYPE ) is -- =================================================================== -- Set the currently active window. -- =================================================================== CENTER_VIEW : GRAPHICS.POINT ; ESC_RECORD : GKS_SPECIFICATION.ESCAPE_RECORD ( GKS_SPECIFICATION.SELECT_WINDOW ); begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.SELECT_WINDOW") ; end if ; -- Select the display window ( graphic, menu, text ) to be used -- for subsequent graphics operation. ESC_RECORD.WINDOW := WINDOW_TO_INDEX ( WINDOW ) ; NON_STD.ESCAPE( GKS_SPECIFICATION.SELECT_WINDOW, ESC_RECORD ); -- place graphics cursor in center of window for graphic window if WINDOW = GRAPH_VIEW_PORT then CENTER_VIEW.X := GRAPHICS.WC( GRAPHIC_WINDOW_RECTANGLE.X.MIN + ( GRAPHIC_WINDOW_RECTANGLE.X.MAX - GRAPHIC_WINDOW_RECTANGLE.X.MIN ) / 2.0 ) ; CENTER_VIEW.Y := GRAPHICS.WC( GRAPHIC_WINDOW_RECTANGLE.Y.MIN + ( GRAPHIC_WINDOW_RECTANGLE.Y.MAX - GRAPHIC_WINDOW_RECTANGLE.Y.MIN ) / 2.0 ) ; PLACE_CURSOR( CENTER_VIEW ) ; end if ; end SELECT_WINDOW ; procedure SET_ABORT_CAPABILITY( ABORT_REQUEST : GRAPHICS.MODE_TYPE ) is -- =================================================================== -- Set the abort capability on or off. If the abort capability is on -- all locator points returned from the terminal will be tested for -- an abort request. -- =================================================================== begin -- If abort capability was requested then set the abort rectangle -- visible and set boolean to show abort capability is active. if ABORT_REQUEST = GRAPHICS.ON then L_1A.SET_VISIBILITY( ABORT_SEGMENT, GKS_SPECIFICATION.VISIBLE ); ABORT_CAPABILITY_ACTIVE := TRUE ; -- Else set abort rectangle invisible and set capability inactive. else L_1A.SET_VISIBILITY( ABORT_SEGMENT, GKS_SPECIFICATION.INVISIBLE ); ABORT_CAPABILITY_ACTIVE := FALSE ; end if ; end SET_ABORT_CAPABILITY ; procedure SET_CHARACTER_SIZE_ATTRIBUTES ( HEIGHT : in GRAPHICS.WC ; WIDTH : in GRAPHICS.WC ; SPACING : in GRAPHICS.WC ; FONT : in GKS_SPECIFICATION.TEXT_PRECISION := GKS_SPECIFICATION.STROKE_PRECISION ) is -- =================================================================== -- Set the character height, the character width, and the spacing -- between characters for subsequent graphic text output. -- =================================================================== GKS_WIDTH : constant GKS_SPECIFICATION.WC.MAGNITUDE := 0.01 ; SCREEN_HEIGHT : constant GKS_SPECIFICATION.WC.MAGNITUDE := GKS_SPECIFICATION.WC.MAGNITUDE( GRAPHIC_WINDOW_RECTANGLE.Y.MAX - GRAPHIC_WINDOW_RECTANGLE.Y.MIN ) ; GKS_HEIGHT : constant GKS_SPECIFICATION.WC.MAGNITUDE := GKS_SPECIFICATION.WC.MAGNITUDE( HEIGHT ) / SCREEN_HEIGHT ; GKS_EXPANSION : constant GKS_SPECIFICATION.CHAR_EXPANSION := GKS_SPECIFICATION.CHAR_EXPANSION( WIDTH ) / GKS_SPECIFICATION.CHAR_EXPANSION( SCREEN_HEIGHT * GKS_WIDTH ) ; GKS_SPACING : constant GKS_SPECIFICATION.CHAR_SPACING := GKS_SPECIFICATION.CHAR_SPACING( SPACING ) / GKS_SPECIFICATION.CHAR_SPACING( SCREEN_HEIGHT ) ; begin -- reset the font precision if necessary if FONT /= CURRENT_FONT then CURRENT_FONT := FONT ; -- set font type to current L_0A.SET_TEXT_FONT_AND_PRECISION( ( 1, CURRENT_FONT ) ) ; end if ; -- Call GKS to set the character height, width, and spacing. L_0A.SET_CHAR_HEIGHT( GKS_HEIGHT ); L_0A.SET_CHAR_EXPANSION_FACTOR( GKS_EXPANSION ); L_0A.SET_CHAR_SPACING( GKS_SPACING ); end SET_CHARACTER_SIZE_ATTRIBUTES ; procedure SET_DRAWING_PRIORITY ( PRIORITY : in PRIORITY_TYPE ) is -- =================================================================== -- Set the visible priority of new segments. -- =================================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.SET_DRAWING_PRIORITY") ; end if ; CURRENT_PRIORITY := PRIORITY ; end SET_DRAWING_PRIORITY ; procedure SET_SEGMENT_VISIBILITY ( SEGMENT : in GKS_SPECIFICATION.SEGMENT_NAME ; MODE : in GKS_SPECIFICATION.SEGMENT_VISIBILITY ) is -- =================================================================== -- Change the segment visibility. -- =================================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.SET_SEGMENT_VISIBILITY") ; end if ; -- Set the specified segment visible or via a call to the GKS -- SET_VISIBILITY procedure. L_1A.SET_VISIBILITY( SEGMENT, MODE ) ; end SET_SEGMENT_VISIBILITY ; procedure TERMINATE_GRAPHICS_MODE is -- ======================================================== -- Restore the device to VT100 mode. -- ======================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.TERMINATE_GRAPHICS_MODE") ; end if ; -- Close the workstation. L_0A.CLOSE_WORKSTATION( ACTIVE_TERMINAL ) ; -- Close the GKS. L_0A.CLOSE_GKS ; end TERMINATE_GRAPHICS_MODE ; procedure UPDATE_COLOR_ATTRIBUTE ( DRAWING_ENTITY : in GRAPHICS.GRAPHIC_ENTITY ; NEW_COLOR : in GRAPHICS.COLOR_TYPE ) is -- ====================================================== -- Update the value of the currently defined color -- attribute for the specified graphic entity. -- ====================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.UPDATE_COLOR_ATTRIBUTE") ; end if ; GRAPHICS.ENTITY_COLOR( DRAWING_ENTITY ) := NEW_COLOR ; end UPDATE_COLOR_ATTRIBUTE ; procedure UPDATE_LINE_ATTRIBUTE ( DRAWING_ENTITY : in GRAPHICS.GRAPHIC_ENTITY ; NEW_LINE : in GRAPHICS.LINE_TYPE ) is -- ====================================================== -- Update the value of the currently defined line -- attribute for the specified graphic entity. -- ====================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.UPDATE_LINE_ATTRIBUTE.") ; end if ; GRAPHICS.ENTITY_LINE( DRAWING_ENTITY ) := NEW_LINE ; end UPDATE_LINE_ATTRIBUTE ; procedure UPDATE_SHAPE_ATTRIBUTE ( DRAWING_ENTITY : in GRAPHICS.FIGURE_ENTITY ; NEW_SHAPE : in GRAPHICS.SHAPE_TYPE ) is -- ====================================================== -- Update the value of the currently defined shape -- attribute for the specified graphic entity. -- ====================================================== begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.UPDATE_SHAPE_ATTRIBUTE") ; end if ; GRAPHICS.ENTITY_SHAPE( DRAWING_ENTITY ) := NEW_SHAPE ; end UPDATE_SHAPE_ATTRIBUTE ; procedure ZOOM ( DIRECTION : in GRAPHICS.ZOOM_DIRECTION ) is -- ====================================================== -- Zoom in or out from the current display. -- ====================================================== NEW_WINDOW : BOOLEAN := false; begin -- debug aid only if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("GRAPHICS_DRIVER.ZOOM") ; end if ; -- If zoom direction is zoom out and window size is not maximum -- window size then determine new window size and reference point. case DIRECTION is when ZOOM_OUT => if WINDOW_SIZE /= ( RANGE_UPPER ) then WINDOW_SIZE := WINDOW_SIZE + 2; X_REF := X_REF - 1; Y_REF := Y_REF + 1; -- Verify that new screen does not exceed boundaries. if X_REF < RANGE_LOWER then X_REF := RANGE_LOWER; end if; if ( X_REF + WINDOW_SIZE ) > RANGE_UPPER then X_REF := RANGE_UPPER - WINDOW_SIZE; end if; if Y_REF > RANGE_UPPER then Y_REF := RANGE_UPPER; end if; if ( Y_REF - WINDOW_SIZE ) < RANGE_LOWER then Y_REF := WINDOW_SIZE; end if; NEW_WINDOW := true; end if; -- If zoom direction is zoom in and window size is not minimum -- window size then determine new window size and reference point. when ZOOM_IN => if WINDOW_SIZE /= ( RANGE_LOWER + 2 ) then WINDOW_SIZE := WINDOW_SIZE - 2; X_REF := X_REF + 1; Y_REF := Y_REF - 1; NEW_WINDOW := true; end if; -- If zoom direction is max zoom out and window size is not maximum -- window size then set max window size and reference point. when MAX_ZOOM_OUT => if WINDOW_SIZE /= RANGE_UPPER then WINDOW_SIZE := RANGE_UPPER ; X_REF := RANGE_UPPER - WINDOW_SIZE; Y_REF := WINDOW_SIZE; NEW_WINDOW := true; end if; -- If zoom direction is max zoom in and window size is not minimum -- window size then set min window size and reference point. when MAX_ZOOM_IN => while WINDOW_SIZE /= RANGE_LOWER + 2 loop WINDOW_SIZE := WINDOW_SIZE - 2; X_REF := X_REF + 1; Y_REF := Y_REF - 1; NEW_WINDOW := true; end loop ; end case ; -- DIRECTION -- If the zoom on the current display can be performed -- then generate a point list defining the new display -- area from the x and y components of the reference point -- and the current window size. if NEW_WINDOW then -- Perform a zoom move by calling the GKS ESCAPE procedure -- with an escape function identifer of SET_TERMINAL_VIEWPORT NEW_GRAPHICS_WINDOW ; -- If window cannot be drawn notify the operator else DISPLAY_ERROR( " current window is on display boundary " ) ; end if; end ZOOM; end GRAPHIC_DRIVER ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --mmi_parameters_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-01-07 09:30 by RAM with SYSTEM ; with VIRTUAL_TERMINAL_INTERFACE ; with GKS_SPECIFICATION ; with GRAPHICS_DATA ; with GRAPHIC_DRIVER ; package MMI_PARAMETERS is -- ============================================================== -- -- This package declares the parameters (types and objects) -- used to implement the Man-Machine Interface. The parameters -- are a key part of the interaction between the MMI control -- routines and the GRAPHICS_DRIVER. -- -- -- =============================================================== subtype FORMAT_FCT is VIRTUAL_TERMINAL_INTERFACE.FORMAT_FUNCTION ; subtype CURSOR_ADDR is VIRTUAL_TERMINAL_INTERFACE.CURSOR_ADDRESS ; subtype ROW_NO is VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE ; subtype COL_NO is VIRTUAL_TERMINAL_INTERFACE.COLUMN_TYPE ; ----------------------------------------------------- -- possible operations to be performed on segments -- by the MMI ----------------------------------------------------- type SEGMENT_OPS_TYPE is ( HILITED , -- hilite the segment DELETED , -- delete the segment RESTORED ) ; -- restore the segment after hiliting ----------------------------------------------------- -- list of GRAPHICS_GENERATOR icons used in each menu -- *** order of icons is critical do not alter *** ----------------------------------------------------- type COMMAND_TYPE is ( -- commands common to menus MENU_LABEL , HELP_CMD , BACKUP_CMD , PAN_ZOOM_CMD , RESTART_CMD , -- commands in MAIN_MENU DESIGN_CMD , ATTRIBUTES_CMD , GEN_PDL_CMD , READ_FILE_CMD , WRITE_FILE_CMD , PRINT_CMD , QUIT_CMD , FINISHED_CMD , -- commands in DESIGN_MENU VIRT_PACKAGE_CMD , PACKAGE_CMD , PROCEDURE_CMD , FUNCTION_CMD , TASK_CMD , ENTRY_PT_CMD , BODY_CMD , ANNOTATION_CMD , CALL_CONNECT_CMD , DATA_CONNECT_CMD , EXPORT_CONNECT_CMD , DELETE_CONNECT_CMD , DELETE_CMD , RESIZE_CMD , MOVE_CMD , MODIFY_CMD , -- commands in PAN_ZOOM_MENU PAN_UP_CMD , PAN_DOWN_CMD , PAN_LEFT_CMD , PAN_RIGHT_CMD , ZOOM_IN_CMD , ZOOM_OUT_CMD , MAX_PAN_UP_CMD , MAX_PAN_DOWN_CMD , MAX_PAN_LEFT_CMD , MAX_PAN_RIGHT_CMD , MAX_ZOOM_IN_CMD , MAX_ZOOM_OUT_CMD , -- commands in ATTRIBUTES_MENU A_VIRT_PACKAGE_CMD , A_PACKAGE_CMD , A_SUBPROGRAM_CMD , A_TASK_CMD , A_CALL_CONNECT_CMD , A_DATA_CONNECT_CMD , A_EXPORT_CONNECT_CMD , -- commands in ANNOTATING_MENU EXPORT_PROC_CMD , EXPORT_FUNC_CMD , EXPORT_TASK_ENTRY_CMD , EXPORT_TYPE_CMD , EXPORT_OBJ_CMD , EXPORT_EXCEPT_CMD , IMPORT_VP_CMD , IMPORT_PKG_CMD , IMPORT_PROC_CMD , IMPORT_FUNC_CMD , IE_CALL_CONNECT_CMD , IE_DATA_CONNECT_CMD , IE_EXPORT_CONNECT_CMD , -- commands in DELETE_MENU CANCEL_CMD , CONFIRM_CMD , -- commands in COLOR_LINE_MENU GREEN_CMD , BLUE_CMD , VIOLET_CMD , RED_CMD , ORANGE_CMD , YELLOW_CMD , BLACK_CMD , SOLID_CMD , DASHED_CMD , DOTTED_CMD , -- commands in GENERIC_MENU NON_GENERIC_CMD , GENERIC_DECL_CMD , GENERIC_INST_CMD , -- commands in PARAMETER_STATUS_MENU HAS_PARAMETERS_CMD , NO_PARAMETERS_CMD , -- commands in CALL_STATUS_MENU UNCONDITIONAL_CMD , CONDITIONAL_CMD , TIMED_CMD , -- commands in ENTRY_POINT_STATUS_MENU UNGUARDED_CMD , GUARDED_CMD , -- commands in PDL_STATUS_MENU WITH_SUPPORT_CMD , NO_SUPPORT_CMD , -- commands in NULL_MENU NULL_CMD ) ; subtype MAIN_MENU_CMD is COMMAND_TYPE range DESIGN_CMD..FINISHED_CMD ; subtype DESIGN_MENU_CMD is COMMAND_TYPE range VIRT_PACKAGE_CMD..MODIFY_CMD ; subtype PAN_ZOOM_MENU_CMD is COMMAND_TYPE range PAN_UP_CMD..ZOOM_OUT_CMD ; subtype ATTRIBUTES_MENU_CMD is COMMAND_TYPE range A_VIRT_PACKAGE_CMD..A_EXPORT_CONNECT_CMD ; subtype ANNOTATING_MENU_CMD is COMMAND_TYPE range EXPORT_PROC_CMD..IE_EXPORT_CONNECT_CMD ; subtype DELETE_MENU_CMD is COMMAND_TYPE range CANCEL_CMD..CONFIRM_CMD ; subtype COLOR_LINE_MENU_CMD is COMMAND_TYPE range GREEN_CMD..DOTTED_CMD ; subtype GENERIC_MENU_CMD is COMMAND_TYPE range NON_GENERIC_CMD..GENERIC_INST_CMD ; subtype PARAMETER_STATUS_MENU_CMD is COMMAND_TYPE range HAS_PARAMETERS_CMD..NO_PARAMETERS_CMD ; subtype CALL_STATUS_MENU_CMD is COMMAND_TYPE range UNCONDITIONAL_CMD..TIMED_CMD ; subtype ENTRY_POINT_STATUS_MENU_CMD is COMMAND_TYPE range UNGUARDED_CMD..GUARDED_CMD ; subtype PDL_STATUS_MENU_CMD is COMMAND_TYPE range WITH_SUPPORT_CMD..NO_SUPPORT_CMD ; subtype NULL_MENU_CMD is COMMAND_TYPE range NULL_CMD..NULL_CMD ; type MENU_ID is ( MAIN_MENU , DESIGN_MENU , PAN_ZOOM_MENU , ATTRIBUTES_MENU , ANNOTATING_MENU , DELETE_MENU , COLOR_LINE_MENU , GENERIC_MENU , PARAMETER_STATUS_MENU , CALL_STATUS_MENU , ENTRY_POINT_STATUS_MENU , PDL_STATUS_MENU , NULL_MENU ) ; ----------------------------------------------------------------- -- The identifiers for icon locations. ----------------------------------------------------------------- subtype ICON_ID is POSITIVE range 1..20 ; ----------------------------------------------------------------- -- This table allows the translation of icon ID's into commands. ----------------------------------------------------------------- MAX_NAME_SIZE : constant POSITIVE := 13 ; NULL_ICON : String( 1..MAX_NAME_SIZE ) := "* null cmd * "; type MENU_TABLE_ENTRY is record COMMAND : COMMAND_TYPE ; NAME : String( 1..MAX_NAME_SIZE ) ; end record ; MENU_TABLE : constant array ( MENU_ID , ICON_ID ) of MENU_TABLE_ENTRY := -- Initialize Menu Table Entries setting values for menu icon and command. ( MAIN_MENU => ( 1 => ( MENU_LABEL , " MAIN MENU " ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( NULL_CMD , NULL_ICON ) , 4 => ( PAN_ZOOM_CMD , " PAN / ZOOM " ) , 5 => ( NULL_CMD , NULL_ICON ) , 6 => ( DESIGN_CMD , " DESIGN " ) , 7 => ( ATTRIBUTES_CMD , "DISPLAY ATTRB" ) , 8 => ( NULL_CMD , NULL_ICON ) , 9 => ( GEN_PDL_CMD , "GENERATE PDL " ) , 10 => ( PRINT_CMD , " PRINT " ) , 11 => ( NULL_CMD , NULL_ICON ) , 12 => ( READ_FILE_CMD , " READ_FILE " ) , 13 => ( WRITE_FILE_CMD , " WRITE_FILE " ) , 14 => ( NULL_CMD , NULL_ICON ) , 15 => ( QUIT_CMD , "QUIT, NO SAVE" ) , 16 => ( FINISHED_CMD , " EXIT & SAVE " ) , 17 => ( NULL_CMD , NULL_ICON ) , 18 => ( NULL_CMD , NULL_ICON ) , 19 => ( NULL_CMD , NULL_ICON ) , 20 => ( NULL_CMD , NULL_ICON ) ) , DESIGN_MENU => ( 1 => ( MENU_LABEL, " DESIGN MENU " ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( BACKUP_CMD , " MENU BACKUP " ) , 4 => ( PAN_ZOOM_CMD , " PAN / ZOOM " ) , 5 => ( NULL_CMD , NULL_ICON ) , 6 => ( VIRT_PACKAGE_CMD , " VIRTUAL PKG " ) , 7 => ( PACKAGE_CMD , " PACKAGE " ) , 8 => ( PROCEDURE_CMD , " PROCEDURE " ) , 9 => ( FUNCTION_CMD , " FUNCTION " ) , 10 => ( TASK_CMD , " TASK " ) , 11 => ( ENTRY_PT_CMD , " ENTRY POINT " ) , 12 => ( BODY_CMD , "XECUTING BODY" ) , 13 => ( ANNOTATION_CMD , "IMPORT/EXPORT" ) , 14 => ( CALL_CONNECT_CMD , " CALL CONN" ) , 15 => ( DATA_CONNECT_CMD , " VISIBLE CONN" ) , 16 => ( EXPORT_CONNECT_CMD , " EXPORTS CONN" ) , 17 => ( DELETE_CONNECT_CMD , " DELETE CONN" ) , 18 => ( DELETE_CMD , "DELETE ENTITY" ) , 19 => ( MOVE_CMD , "MOVE / RESIZE" ) , 20 => ( MODIFY_CMD , "MODIFY ENTITY" ) ) , PAN_ZOOM_MENU => ( 1 => ( MENU_LABEL , "PAN/ZOOM MENU" ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( BACKUP_CMD , "BACKUP/RESUME" ) , 4 => ( NULL_CMD , NULL_ICON ) , 5 => ( NULL_CMD , NULL_ICON ) , 6 => ( PAN_UP_CMD , " PAN UP " ) , 7 => ( PAN_DOWN_CMD , " PAN DOWN " ) , 8 => ( PAN_LEFT_CMD , " PAN LEFT " ) , 9 => ( PAN_RIGHT_CMD , " PAN RIGHT " ) , 10 => ( NULL_CMD , NULL_ICON ) , 11 => ( ZOOM_IN_CMD , " ZOOM IN " ) , 12 => ( ZOOM_OUT_CMD , " ZOOM OUT " ) , 13 => ( NULL_CMD , NULL_ICON ) , 14 => ( MAX_PAN_UP_CMD , "MAX PAN UP " ) , 15 => ( MAX_PAN_DOWN_CMD , "MAX PAN DOWN " ) , 16 => ( MAX_PAN_LEFT_CMD , "MAX PAN LEFT " ) , 17 => ( MAX_PAN_RIGHT_CMD , "MAX PAN RIGHT" ) , 18 => ( NULL_CMD , NULL_ICON ) , 19 => ( MAX_ZOOM_IN_CMD , "MAX ZOOM IN " ) , 20 => ( MAX_ZOOM_OUT_CMD , "MAX ZOOM OUT " ) ) , -- commands in ATTRIBUTES_MENU ATTRIBUTES_MENU => ( 1 => ( MENU_LABEL , " ATTRIBUTES " ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( BACKUP_CMD , " MENU BACKUP " ) , 4 => ( PAN_ZOOM_CMD , " PAN / ZOOM " ) , 5 => ( NULL_CMD , NULL_ICON ) , 6 => ( A_VIRT_PACKAGE_CMD , "VIRTUAL PKGS " ) , 7 => ( A_PACKAGE_CMD , " PACKAGES " ) , 8 => ( A_SUBPROGRAM_CMD , " SUBPROGRAMS " ) , 9 => ( A_TASK_CMD , " TASKS " ) , 10 => ( NULL_CMD , NULL_ICON ) , 11 => ( A_CALL_CONNECT_CMD , " CALL CONN" ) , 12 => ( A_DATA_CONNECT_CMD , " VISIBLE CONN" ) , 13 => ( A_EXPORT_CONNECT_CMD," EXPORTS CONN" ) , 14 => ( NULL_CMD , NULL_ICON ) , 15 => ( NULL_CMD , NULL_ICON ) , 16 => ( NULL_CMD , NULL_ICON ) , 17 => ( NULL_CMD , NULL_ICON ) , 18 => ( NULL_CMD , NULL_ICON ) , 19 => ( NULL_CMD , NULL_ICON ) , 20 => ( NULL_CMD , NULL_ICON ) ) , -- commands in ANNOTATING_MENU ANNOTATING_MENU => ( 1 => ( MENU_LABEL , "IMPORT/EXPORT" ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( BACKUP_CMD , " MENU BACKUP " ) , 4 => ( PAN_ZOOM_CMD , " PAN / ZOOM " ) , 5 => ( RESTART_CMD , " MAIN MENU " ) , 6 => ( NULL_CMD , NULL_ICON ) , 7 => ( EXPORT_PROC_CMD , "EXPORT PROC " ) , 8 => ( EXPORT_FUNC_CMD , "EXPORT FUNC " ) , 9 => ( EXPORT_TYPE_CMD , "EXPORT TYPE " ) , 10 => ( EXPORT_OBJ_CMD , "EXPORT OBJECT" ) , 11 => ( EXPORT_EXCEPT_CMD , "EXPORT EXCEPT" ) , 12 => ( EXPORT_TASK_ENTRY_CMD, "EXPORT ENTRY " ) , 13 => ( IMPORT_VP_CMD , "IMPORT VT PKG" ) , 14 => ( IMPORT_PKG_CMD , "IMPORT PKG " ) , 15 => ( IMPORT_PROC_CMD , "IMPORT PROC " ) , 16 => ( IMPORT_FUNC_CMD , "IMPORT FUNC " ) , 17 => ( NULL_CMD , NULL_ICON ) , 18 => ( IE_CALL_CONNECT_CMD , " CALL CONN" ) , 19 => ( IE_DATA_CONNECT_CMD , " VISIBLE CONN" ) , 20 => ( IE_EXPORT_CONNECT_CMD ," EXPORTS CONN" ) ) , -- commands in DELETE_MENU DELETE_MENU => ( 1 => ( MENU_LABEL , " DELETE/QUIT " ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( BACKUP_CMD , " MENU BACKUP " ) , 4 => ( NULL_CMD , NULL_ICON ) , 5 => ( NULL_CMD , NULL_ICON ) , 6 => ( CANCEL_CMD , " CANCEL " ) , 7 => ( CONFIRM_CMD , " CONFIRM " ) , 8 => ( NULL_CMD , NULL_ICON ) , 9 => ( NULL_CMD , NULL_ICON ) , 10 => ( NULL_CMD , NULL_ICON ) , 11 => ( NULL_CMD , NULL_ICON ) , 12 => ( NULL_CMD , NULL_ICON ) , 13 => ( NULL_CMD , NULL_ICON ) , 14 => ( NULL_CMD , NULL_ICON ) , 15 => ( NULL_CMD , NULL_ICON ) , 16 => ( NULL_CMD , NULL_ICON ) , 17 => ( NULL_CMD , NULL_ICON ) , 18 => ( NULL_CMD , NULL_ICON ) , 19 => ( NULL_CMD , NULL_ICON ) , 20 => ( NULL_CMD , NULL_ICON ) ) , -- commands in COLOR_LINE_MENU COLOR_LINE_MENU => ( 1 => ( MENU_LABEL , " COLOR/LINE " ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( BACKUP_CMD , " MENU BACKUP " ) , 4 => ( NULL_CMD , NULL_ICON ) , 5 => ( RESTART_CMD ," MAIN MENU " ) , 6 => ( NULL_CMD , NULL_ICON ) , 7 => ( GREEN_CMD , "GREEN " ) , 8 => ( BLUE_CMD , "BLUE " ) , 9 => ( VIOLET_CMD , "VIOLET " ) , 10 => ( RED_CMD , "RED " ) , 11 => ( ORANGE_CMD , "ORANGE " ) , 12 => ( YELLOW_CMD , "YELLOW " ) , 13 => ( BLACK_CMD , "BLACK " ) , 14 => ( NULL_CMD , NULL_ICON ) , 15 => ( SOLID_CMD , "SOLID _____ " ) , 16 => ( DASHED_CMD , "DASHED _ _ _ " ) , 17 => ( DOTTED_CMD , "DOTTED ..... " ) , 18 => ( NULL_CMD , NULL_ICON ) , 19 => ( NULL_CMD , NULL_ICON ) , 20 => ( NULL_CMD , NULL_ICON ) ) , -- commands in GENERIC_MENU GENERIC_MENU => ( 1 => ( MENU_LABEL , "GENERIC MENU " ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( BACKUP_CMD , " MENU BACKUP " ) , 4 => ( NULL_CMD , NULL_ICON ) , 5 => ( NULL_CMD , NULL_ICON ) , 6 => ( NON_GENERIC_CMD , " DECLARATION " ) , 7 => ( GENERIC_DECL_CMD , "GENERIC DECLA" ) , 8 => ( GENERIC_INST_CMD , "GENERIC INSTA" ) , 9 => ( NULL_CMD , NULL_ICON ) , 10 => ( NULL_CMD , NULL_ICON ) , 11 => ( NULL_CMD , NULL_ICON ) , 12 => ( NULL_CMD , NULL_ICON ) , 13 => ( NULL_CMD , NULL_ICON ) , 14 => ( NULL_CMD , NULL_ICON ) , 15 => ( NULL_CMD , NULL_ICON ) , 16 => ( NULL_CMD , NULL_ICON ) , 17 => ( NULL_CMD , NULL_ICON ) , 18 => ( NULL_CMD , NULL_ICON ) , 19 => ( NULL_CMD , NULL_ICON ) , 20 => ( NULL_CMD , NULL_ICON ) ) , -- commands in PARAMETER_STATUS_MENU PARAMETER_STATUS_MENU => ( 1 => ( MENU_LABEL , "PARAM STATUS " ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( BACKUP_CMD , " MENU BACKUP " ) , 4 => ( NULL_CMD , NULL_ICON ) , 5 => ( NULL_CMD , NULL_ICON ) , 6 => ( HAS_PARAMETERS_CMD, " HAS PARAMS " ) , 7 => ( NO_PARAMETERS_CMD , " NO PARAMS " ) , 8 => ( NULL_CMD , NULL_ICON ) , 9 => ( NULL_CMD , NULL_ICON ) , 10 => ( NULL_CMD , NULL_ICON ) , 11 => ( NULL_CMD , NULL_ICON ) , 12 => ( NULL_CMD , NULL_ICON ) , 13 => ( NULL_CMD , NULL_ICON ) , 14 => ( NULL_CMD , NULL_ICON ) , 15 => ( NULL_CMD , NULL_ICON ) , 16 => ( NULL_CMD , NULL_ICON ) , 17 => ( NULL_CMD , NULL_ICON ) , 18 => ( NULL_CMD , NULL_ICON ) , 19 => ( NULL_CMD , NULL_ICON ) , 20 => ( NULL_CMD , NULL_ICON ) ) , -- commands in CALL_STATUS_MENU CALL_STATUS_MENU => ( 1 => ( MENU_LABEL , " CALL STATUS " ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( BACKUP_CMD , " MENU BACKUP " ) , 4 => ( NULL_CMD , NULL_ICON ) , 5 => ( NULL_CMD , NULL_ICON ) , 6 => ( UNCONDITIONAL_CMD , "UNCONDITIONAL" ) , 7 => ( CONDITIONAL_CMD , " CONDITIONAL " ) , 8 => ( TIMED_CMD , " TIMED " ) , 9 => ( NULL_CMD , NULL_ICON ) , 10 => ( NULL_CMD , NULL_ICON ) , 11 => ( NULL_CMD , NULL_ICON ) , 12 => ( NULL_CMD , NULL_ICON ) , 13 => ( NULL_CMD , NULL_ICON ) , 14 => ( NULL_CMD , NULL_ICON ) , 15 => ( NULL_CMD , NULL_ICON ) , 16 => ( NULL_CMD , NULL_ICON ) , 17 => ( NULL_CMD , NULL_ICON ) , 18 => ( NULL_CMD , NULL_ICON ) , 19 => ( NULL_CMD , NULL_ICON ) , 20 => ( NULL_CMD , NULL_ICON ) ) , -- commands in ENTRY_POINT_STATUS_MENU ENTRY_POINT_STATUS_MENU => ( 1 => ( MENU_LABEL , "ENTRY STATUS " ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( BACKUP_CMD , " MENU BACKUP " ) , 4 => ( NULL_CMD , NULL_ICON ) , 5 => ( NULL_CMD , NULL_ICON ) , 6 => ( UNGUARDED_CMD , " UNGUARDED " ) , 7 => ( GUARDED_CMD , " GUARDED " ) , 8 => ( NULL_CMD , NULL_ICON ) , 9 => ( NULL_CMD , NULL_ICON ) , 10 => ( NULL_CMD , NULL_ICON ) , 11 => ( NULL_CMD , NULL_ICON ) , 12 => ( NULL_CMD , NULL_ICON ) , 13 => ( NULL_CMD , NULL_ICON ) , 14 => ( NULL_CMD , NULL_ICON ) , 15 => ( NULL_CMD , NULL_ICON ) , 16 => ( NULL_CMD , NULL_ICON ) , 17 => ( NULL_CMD , NULL_ICON ) , 18 => ( NULL_CMD , NULL_ICON ) , 19 => ( NULL_CMD , NULL_ICON ) , 20 => ( NULL_CMD , NULL_ICON ) ) , -- commands in PDL_STATUS_MENU PDL_STATUS_MENU => ( 1 => ( MENU_LABEL , " PDL STATUS " ) , 2 => ( HELP_CMD , " HELP " ) , 3 => ( BACKUP_CMD , " MENU BACKUP " ) , 4 => ( NULL_CMD , NULL_ICON ) , 5 => ( NULL_CMD , NULL_ICON ) , 6 => ( WITH_SUPPORT_CMD , "WITH SUPPORT " ) , 7 => ( NO_SUPPORT_CMD , " NO SUPPORT " ) , 8 => ( NULL_CMD , NULL_ICON ) , 9 => ( NULL_CMD , NULL_ICON ) , 10 => ( NULL_CMD , NULL_ICON ) , 11 => ( NULL_CMD , NULL_ICON ) , 12 => ( NULL_CMD , NULL_ICON ) , 13 => ( NULL_CMD , NULL_ICON ) , 14 => ( NULL_CMD , NULL_ICON ) , 15 => ( NULL_CMD , NULL_ICON ) , 16 => ( NULL_CMD , NULL_ICON ) , 17 => ( NULL_CMD , NULL_ICON ) , 18 => ( NULL_CMD , NULL_ICON ) , 19 => ( NULL_CMD , NULL_ICON ) , 20 => ( NULL_CMD , NULL_ICON ) ) , -- initialize all others to null NULL_MENU => ( others => ( NULL_CMD , NULL_ICON ) ) ) ; SESSION_NAME : STRING (1..40) := ( others => ' ' ) ; -- A FILENAME ----------------------------------------------------------------- -- Define the array containing the segment numbers of the menu -- icons indexed by menu and icon. ----------------------------------------------------------------- ICON_SEGMENTS : array ( MENU_ID ) of GRAPHICS_DATA.SEGMENT_LIST_TYPE( ICON_ID'first..ICON_ID'last ) := ( MAIN_MENU..NULL_MENU => ( ICON_ID'first..ICON_ID'last => GRAPHICS_DATA.NULL_SEGMENT ) ) ; ----------------------------------------------------------------- -- Define the array containing the segment numbers of the color -- menu color square icons. ----------------------------------------------------------------- ICON_COLOR_SEGMENTS : GRAPHICS_DATA.SEGMENT_LIST_TYPE ( COMMAND_TYPE'Pos( GREEN_CMD )..COMMAND_TYPE'Pos( BLACK_CMD ) ) ; ---------------------------------------------------------------- -- icon location to id cross reference of lower BOUNDARY ---------------------------------------------------------------- type BOUNDARY_VALUES is record UPPER : GRAPHICS_DATA.WC ; LOWER : GRAPHICS_DATA.WC ; end record ; ICON_BOUNDARY : array ( ICON_ID ) of BOUNDARY_VALUES ; ---------------------------------------------------------------- -- Minimum and maximum X values for menu rectangle. ---------------------------------------------------------------- MENU_X_MIN, MENU_X_MAX : GRAPHICS_DATA.WC ; ---------------------------------------------------------------- -- Menu which is currently displayed to operator. ---------------------------------------------------------------- CURRENT_MENU : MENU_ID := NULL_MENU ; ---------------------------------------------------------------- -- Local exceptions indicating an invalid symbol was selected or -- the user attempted to improperly use a command. ---------------------------------------------------------------- INVALID_COMMAND_SELECTED : exception ; IMPROPER_COMMAND_USAGE : exception ; ---------------------------------------------------------------- -- Exceptions to abort a create and return to higher menu -- to return to the main menu ---------------------------------------------------------------- HANDLE_ABORT_BACKUP : exception ; HANDLE_RESTART : exception ; end MMI_PARAMETERS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --utilities_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-11-01 17:10 by JL with SYSTEM ; with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; with GRAPHICS_DATA ; use GRAPHICS_DATA ; with MMI_PARAMETERS ; use MMI_PARAMETERS ; package UTILITIES is -- =========================================================== -- -- This package provides the common MMI functions, implemented -- so as to use the formated screen and mouse selected command -- features of the GRAPHICS_INTERFACE. -- -- This package provides the help facility. Help can be provided -- on each command level. -- -- The specification is null for compilation under compiler -- version 1.5 -- -- package split into "UTIL_FOR_TREE" 27 Aug 1985 due to compiler -- code generation restrictions -- ========================================================== package GRAPHICS renames GRAPHICS_DATA ; procedure DIMENSION_CHECK ( SHAPE : in GRAPHICS_DATA.SHAPE_TYPE ; POINT_A : in GRAPHICS_DATA.POINT ; POINT_B : in out GRAPHICS_DATA.POINT ) ; -- ========================================================= -- This procedure checks that point b has the minimum -- magnitudes from point a in the x & y directions based -- on the type of object being drawn. If any errors occur -- then the user is notified and the new point b position -- is drawn and confirmation is required. -- ========================================================= procedure DISPLAY_ERROR ( DISPLAY_STRING : in STRING ); -- ========================================================= -- This procedure displays the received string to the -- operator, waits for an operator acknowledgement, and -- clears the displayed line. -- ========================================================= procedure DISPLAY_CONTINUE ; -- ========================================================= -- This procedure displays the message "PRESS CURSOR -- CONTROL DEVICE TO CONTINUE" to the operator, waits -- for an operator acknowledgement, and clears the -- displayed line. -- ========================================================= procedure DISPLAY_TIMED_MESSAGE ( DISPLAY_STRING : in STRING ); -- ========================================================= -- This procedure displays the received string to the -- operator, waits for an appropriate delay, then continues -- ========================================================= procedure DISPLAY_MENU ( MENU : in MENU_ID ; COMMAND : in COMMAND_TYPE ) ; -- ========================================================== -- Display the appropriate menu and highlight the specified -- command. -- ========================================================== procedure DISPLAY_MENU_AND_GET_COMMAND ( MENU : in MENU_ID ; NEW_COMMAND : in out COMMAND_TYPE ) ; -- ========================================================== -- Display the appropriate menu, preset the cursor and get -- the user selected command. New_command passed in is the -- desired icon location of the cursor. -- ========================================================== procedure HELP ( MENU : in MENU_ID ) ; -- ======================================================== -- This procedure provides help for the current -- Command Level and all levels beneath it. The format of -- the help will be textual (i.e., it will be implemented -- on the Text plane of the terminal so as to not interfere -- with the graphics. -- ========================================================= procedure PRESET_ICON_CURSOR ( MENU : in MENU_ID ; COMMAND : in COMMAND_TYPE ) ; -- ========================================================== -- Place the cursor on the icon that corresponds to the -- specified command of current menu. -- ========================================================== procedure REFERENCE_MARKER ( MODE : in GKS_SPECIFICATION.SEGMENT_VISIBILITY ; LOCATION : in GRAPHICS_DATA.POINT ) ; -- ========================================================== -- Place the system marker segment at the specified location -- and set the segment visible or invisible. -- ========================================================== procedure SIGN_ON ; -- ========================================================== -- This routine provides initial system start up utilities -- such as clearing the terminal screen, displaying a -- copyright message, etc. -- ========================================================== function TRUNCATE_NAME ( USER_NAME : in String ; SPACE_WIDTH : in Natural ; PARAMS_SYMBOL : in Boolean := False ) return STRING; -- ========================================================== -- Truncate the user name to a width which will fit into -- the user specified space width, and return the -- truncate name. -- ========================================================== function VALID_DRAWING_BOUNDARIES ( LOCATION : GRAPHICS_DATA.POINT ) return Boolean ; -- ============================================================ -- determin if a point can be drawn within the drawing boundry -- area that is defined with label buffer zone for move and -- resize functions on entities. -- ============================================================ --------------------------------------------------------------- -- This exception is raised if an utility subprogram is unable -- to properly complete the requested operation. --------------------------------------------------------------- UTILITY_FAILED : exception ; PROTOTYPE_SIGN_ON : Boolean ; end UTILITIES ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --utilities_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-01-15 1210 by JL with GRAPHIC_DRIVER ; use GRAPHIC_DRIVER ; with VIRTUAL_TERMINAL_INTERFACE ; use VIRTUAL_TERMINAL_INTERFACE ; with TEXT_IO ; use TEXT_IO; with TRACE_PKG ; package body UTILITIES is -- ============================================================ -- -- This package provides the common MMI functions, implemented -- so as to use the formated screen and mouse selected command -- features of the GRAPHICS_INTERFACE. -- -- This package provides the help facility. Help can be provided -- on each command level. -- -- ============================================================= subtype FORMAT_FCT is VIRTUAL_TERMINAL_INTERFACE.FORMAT_FUNCTION ; subtype CURSOR_ADDR is VIRTUAL_TERMINAL_INTERFACE.CURSOR_ADDRESS ; subtype ROW_NO is VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE ; subtype COL_NO is VIRTUAL_TERMINAL_INTERFACE.COLUMN_TYPE ; -- Icon identifier of command which has been picked by operator ICON : ICON_ID := ICON_ID'first ; -- Current menu icon segment which is highlighted SEGMENT_TO_HIGHLIGHT : GKS_SPECIFICATION.SEGMENT_NAME := GRAPHICS_DATA.NULL_SEGMENT ; -- Segments which contains drawing marker and their current location. PRIMARY_MARKER_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME := GRAPHICS_DATA.NULL_SEGMENT ; SECONDARY_MARKER_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME := GRAPHICS_DATA.NULL_SEGMENT ; -- alailability flags for marker usage PRIMARY_AVAILABLE : Boolean := True ; SECONDARY_AVAILABLE : Boolean := True ; --{{ Utilities to be placed here as they are recognized, one --{{ example is given below. procedure DIMENSION_CHECK ( SHAPE : in GRAPHICS_DATA.SHAPE_TYPE ; POINT_A : in GRAPHICS_DATA.POINT ; POINT_B : in out GRAPHICS_DATA.POINT ) is -- ========================================================= -- This procedure checks that point b has the minimum -- magnatudes from point a in the x & y directions based -- on the type of object being drawn. If any errors occur -- then the user is notified and the new point b position -- is drawn and confirmation is required. -- ========================================================= TEMP_X_MAG , X_MAGNITUDE : GRAPHICS_DATA.WC ; Y_MAGNITUDE : GRAPHICS_DATA.WC ; MIN_CHAR_MAG : constant GRAPHICS_DATA.WC := 150 ; -- minimum 12 character range begin -- get current MAGNITUDEs X_MAGNITUDE := abs ( POINT_B.X - POINT_A.X ) ; Y_MAGNITUDE := abs ( POINT_A.Y - POINT_B.Y ) ; -- set minimum x for all shapes if MIN_CHAR_MAG > X_MAGNITUDE then POINT_B.X := POINT_A.X + MIN_CHAR_MAG ; X_MAGNITUDE := MIN_CHAR_MAG ; end if ; -- set minimum shape size { aspect ratio } case SHAPE is when SQUARE | CIRCLE => -- set all sides to the minimum side if X_MAGNITUDE < Y_MAGNITUDE then POINT_B.Y := POINT_A.Y - X_MAGNITUDE ; else POINT_B.X := POINT_B.X + Y_MAGNITUDE ; end if ; when PARALLELOGRAM => -- calc the minimum x MAGNITUDE TEMP_X_MAG := GRAPHICS_DATA.WC ( Y_MAGNITUDE / 3 ) + MIN_CHAR_MAG ; -- set minimum x MAGNITUDE if TEMP_X_MAG > X_MAGNITUDE then POINT_B.X := POINT_A.X + TEMP_X_MAG ; X_MAGNITUDE := TEMP_X_MAG ; end if ; when SINGLE_RECTANGLE | STACKED_RECTANGLE => -- all check have allready been done null ; when others => -- other shapes don't need any adjustments null ; end case ; -- SHAPE -- [ if any changes made then notify user and display points -- on screen then get confirmation of adjustments ] end DIMENSION_CHECK ; procedure DISPLAY_ERROR ( DISPLAY_STRING : in STRING ) is -- ========================================================= -- This procedure displays the received string to the -- operator, waits for an operator acknowledgement, and -- clears the displayed line. -- ========================================================= DUMMY_POINT : GRAPHICS_DATA.POINT ; BLANK_LINE : constant STRING := " " ; CONTINUE : constant STRING := " Press cursor control device to continue " ; OPERATOR_RESPONSE : STRING(1..1) ; BELL_STRING : constant String(1..1) := ( others => ASCII.BEL ) ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( " ERROR MESSAGE DISPLAYED :") ; TRACE_PKG.TRACE( DISPLAY_STRING ) ; end if ; -- ring the bell to get users attention VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BELL_STRING, FORMAT_FCT'( CENTER_A_LINE ), ROW_NO( 24 )) ; -- clear the area surrounding the displayed error message VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FCT'( CLEAR_A_LINE ), ROW_NO( 9 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FCT'( CLEAR_A_LINE ), ROW_NO( 10 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FCT'( CLEAR_A_LINE ), ROW_NO( 11 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FCT'( CLEAR_A_LINE ), ROW_NO( 12 )) ; -- display received string and continue message VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( DISPLAY_STRING, FORMAT_FCT'( CENTER_A_LINE ), ROW_NO( 10 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( CONTINUE, FORMAT_FCT'( CENTER_A_LINE ), ROW_NO( 11 )) ; -- wait for operator acknowledgement -- use a <CR> for ack -- VIRTUAL_TERMINAL_INTERFACE.STRINGIO( -- OPERATOR_RESPONSE, -- VIRTUAL_TERMINAL_INTERFACE.READ_WITH_ADDRESS, -- ROW_NO( 23 ), -- COL_NO( 1 ) ) ; -- use locator for ack DUMMY_POINT := GRAPHIC_DRIVER.GET_GRAPHICS_CURSOR_POSITION ; -- clear the messages VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FCT'( CLEAR_A_LINE ), ROW_NO( 10 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FCT'( CLEAR_A_LINE ), ROW_NO( 11 )) ; exception -- dont let the operator abort during display error when OPERATION_ABORTED_BY_OPERATOR => null ; -- propogate any unknown error when others => raise ; end DISPLAY_ERROR ; procedure DISPLAY_CONTINUE is -- ========================================================= -- This procedure displays the message "PRESS CURSOR -- CONTROL DEVICE TO CONTINUE" to the operator, waits -- for an operator acknowledgement, and clears the -- displayed line. -- ========================================================= DUMMY_POINT : GRAPHICS_DATA.POINT ; BLANK_LINE : constant STRING := " " ; CONTINUE : constant STRING := " Press cursor control device to continue " ; OPERATOR_RESPONSE : STRING(1..1) ; BELL_STRING : constant String(1..1) := ( others => ASCII.BEL ) ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE( " PROCEDURE DISPLAY_CONTINUE") ; end if ; -- ring the bell to get users attention VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BELL_STRING, FORMAT_FCT'( CENTER_A_LINE ), ROW_NO( 24 )) ; -- display continue message VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( CONTINUE, FORMAT_FCT'( CENTER_A_LINE ), ROW_NO( 24 )) ; -- wait for operator acknowledgement DUMMY_POINT := GRAPHIC_DRIVER.GET_GRAPHICS_CURSOR_POSITION ; -- clear the messages VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FCT'( CLEAR_A_LINE ), ROW_NO( 24 )) ; end DISPLAY_CONTINUE ; procedure DISPLAY_TIMED_MESSAGE ( DISPLAY_STRING : in STRING ) is -- ========================================================= -- This procedure displays the received string to the -- operator, (note that NEW_LINE is called so -- that the IO is completed) waits for an appropriate -- delay, then continues -- ========================================================= begin -- display received string VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( DISPLAY_STRING , FORMAT_FCT'( CENTER_A_LINE ), ROW_NO( 23 )) ; TEXT_IO.NEW_LINE ; -- delay in seconds delay 2.0 ; -- clear the message VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; end DISPLAY_TIMED_MESSAGE ; procedure DISPLAY_MENU ( MENU : in MENU_ID ; COMMAND : in COMMAND_TYPE ) is -- ========================================================== -- Display the appropriate menu and highlight the specified -- command. -- ========================================================== FOUND : boolean := false ; begin -- If requested menu is different than current menu then display -- the requested menu. if CURRENT_MENU /= MENU then GRAPHIC_DRIVER.CLEAR_MENU( ICON_SEGMENTS( CURRENT_MENU )) ; GRAPHIC_DRIVER.DISPLAY_MENU( ICON_SEGMENTS( MENU )) ; CURRENT_MENU := MENU ; end if; -- Turn segment highlight off if highlight is active. if SEGMENT_TO_HIGHLIGHT /= GRAPHICS_DATA.NULL_SEGMENT then GRAPHIC_DRIVER.HILITE_SEGMENT( SEGMENT_TO_HIGHLIGHT, GKS_SPECIFICATION.NORMAL ) ; SEGMENT_TO_HIGHLIGHT := GRAPHICS_DATA.NULL_SEGMENT ; end if ; -- If specified command is not the null command then highlight -- the corresponding menu icon. if COMMAND /= NULL_CMD then -- Locate the icon correspond to the specified command. for ICON_INDEX in ICON_ID'first..ICON_ID'last loop if MENU_TABLE ( CURRENT_MENU, ICON_INDEX ).COMMAND = COMMAND then FOUND := true ; ICON := ICON_INDEX ; exit ; end if ; end loop ; if FOUND then SEGMENT_TO_HIGHLIGHT := MMI_PARAMETERS.ICON_SEGMENTS( CURRENT_MENU )( ICON ); GRAPHIC_DRIVER.HILITE_SEGMENT( SEGMENT_TO_HIGHLIGHT, GKS_SPECIFICATION.HIGHLIGHTED ) ; end if; end if; end DISPLAY_MENU ; procedure DISPLAY_MENU_AND_GET_COMMAND ( MENU : in MENU_ID ; NEW_COMMAND : in out COMMAND_TYPE ) is -- ========================================================== -- Display the appropriate menu, preset the cursor and get -- the user selected command. New_command passed in is the -- desired icon location of the cursor. -- ========================================================== LINE_1 : constant STRING := " INVALID MENU ICON SELECTION - TRY AGAIN" ; LINE_2 : constant STRING := " SELECT A MENU ICON. " ; POSITION : GRAPHICS_DATA.POINT ; VALID_COMMAND : boolean := false ; INVALID_ICON_SELECTION : exception ; begin -- If requested menu is different than current menu then display -- the requested menu. if CURRENT_MENU /= MENU then if CURRENT_MENU = COLOR_LINE_MENU then GRAPHIC_DRIVER.CLEAR_MENU( ICON_COLOR_SEGMENTS ) ; end if ; GRAPHIC_DRIVER.CLEAR_MENU( ICON_SEGMENTS( CURRENT_MENU )) ; GRAPHIC_DRIVER.DISPLAY_MENU( ICON_SEGMENTS( MENU )) ; if MENU = COLOR_LINE_MENU then GRAPHIC_DRIVER.DISPLAY_MENU( ICON_COLOR_SEGMENTS ) ; end if ; CURRENT_MENU := MENU ; end if; -- preset the cursor on the desired command PRESET_ICON_CURSOR( MENU , NEW_COMMAND ) ; -- Turn segment highlight off if highlight is active. if SEGMENT_TO_HIGHLIGHT /= GRAPHICS_DATA.NULL_SEGMENT then GRAPHIC_DRIVER.HILITE_SEGMENT( SEGMENT_TO_HIGHLIGHT, GKS_SPECIFICATION.NORMAL ) ; end if ; -- Get the new icon selection. -- Request the position of the graphics cursor and translate the -- cursor position into a menu icon. while not VALID_COMMAND loop -- until valid menu icon is selected begin ICON := ICON_ID'first ; POSITION := GRAPHIC_DRIVER.GET_GRAPHICS_CURSOR_POSITION ; loop if ( POSITION.Y >= ICON_BOUNDARY( ICON ).LOWER ) and ( POSITION.Y <= ICON_BOUNDARY( ICON ).UPPER ) then exit ; else if ICON = ICON_ID'last then raise INVALID_ICON_SELECTION ; else ICON := ICON + 1 ; end if ; end if; end loop; -- Cross reference icon to get command. NEW_COMMAND := MENU_TABLE( MENU, ICON ).COMMAND ; if NEW_COMMAND = NULL_CMD or NEW_COMMAND = MENU_LABEL then raise INVALID_ICON_SELECTION ; else VALID_COMMAND := true ; end if ; exception when INVALID_ICON_SELECTION => -- Display invalid selection error message. if NEW_COMMAND = NULL_CMD then DISPLAY_ERROR( LINE_1 ) ; else DISPLAY_ERROR( LINE_2 ) ; end if ; end ; end loop ; SEGMENT_TO_HIGHLIGHT := MMI_PARAMETERS.ICON_SEGMENTS( CURRENT_MENU )( ICON ); -- Highlight picked icon. GRAPHIC_DRIVER.HILITE_SEGMENT( SEGMENT_TO_HIGHLIGHT, GKS_SPECIFICATION.HIGHLIGHTED ) ; end DISPLAY_MENU_AND_GET_COMMAND ; procedure HELP ( MENU : in MENU_ID ) is -- ========================================================== -- This procedure provides help for the current -- Command Level and all levels beneath it. The format of -- the help will be textual (i.e., it will be implemented -- on the Text plane of the terminal so as to not interfere -- with the graphics. -- *** -- Suggested modification to help file manipulation. -- have page directory at start of file which translates -- search string into a page number; -- then loop on page number to place file pointer at -- beginning of proper page -- ========================================================== HELP_LENGTH : constant NATURAL := 70 ; subtype HELP_STRING is STRING(1..HELP_LENGTH); HELP_FILE : TEXT_IO.FILE_TYPE; FILE_NAME : constant STRING := "HELP_FILE" ; FILE_STRING : HELP_STRING ; BLNK_STRING : constant HELP_STRING := " " & " "; -- 12345678901234567890123456789012345 NO_OF_CHAR : NATURAL; REQ_PAGE : TEXT_IO.POSITIVE_COUNT ; COLUMN_COUNT : constant VIRTUAL_TERMINAL_INTERFACE.COLUMN_TYPE := 18 ; DEFAULT_CMD : constant MMI_PARAMETERS.COMMAND_TYPE := MMI_PARAMETERS.HELP_CMD ; SELECTED_CMD : MMI_PARAMETERS.COMMAND_TYPE ; BELL_CHAR : CHARACTER := ASCII.BEL ; NO_FILE : constant STRING := " HELP FILE NOT AVAILABLE "; CANT_FIND_1 : constant STRING := " HELP FOR "; CANT_FIND_2 : constant STRING := " IS NOT AVAILABLE "; HEADER_LENGTH : constant POSITIVE := 15 ; subtype HEADER_STRING is STRING( 1..HEADER_LENGTH ); HELP_ICON_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME := GRAPHICS_DATA.NULL_SEGMENT ; HELP_ICON_HIGHLIGHTED : BOOLEAN := false ; procedure DISPLAY_HELP( SEARCH_STRING : in STRING ) is -- ========================================================== -- This procedure searches the help file for the menu or -- command string contained in SEARCH_STRING, and displays -- the associated help text. -- ========================================================== BEGIN_STRING : constant NATURAL := SEARCH_STRING'first ; END_STRING : constant NATURAL := SEARCH_STRING'last ; ROW_COUNT : VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE := 1 ; LAST_ROW : constant VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE := 19 ; COMMAND_ROW : constant VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE := 20 ; EXIT_ROW : constant VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE := 21 ; START_CHAR : NATURAL ; TEXT_OFFSET : constant NATURAL := 9; subtype INFO_STRING is STRING( 1..48 ); OPERATOR_RESPONSE : STRING(1..1) ; COMMAND_HELP : INFO_STRING := " Select command for help on a specific command. "; EXIT_HELP : INFO_STRING := " Select HELP to exit from HELP display. "; begin -- Erase any text currently on the screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( LOW_LEVEL_CRT_FUNCTIONS'( ERASE_SCREEN )) ; begin -- Reset the file so file elements are read from start of file. TEXT_IO.RESET( HELP_FILE ) ; -- Search for file page containing the help text. loop TEXT_IO.GET_LINE( HELP_FILE, FILE_STRING, NO_OF_CHAR ); if SEARCH_STRING = FILE_STRING( BEGIN_STRING..END_STRING ) then exit; else TEXT_IO.SKIP_PAGE( HELP_FILE ); end if; end loop ; -- Display help text on screen. ROW_COUNT := 1; REQ_PAGE := TEXT_IO.PAGE( HELP_FILE ) ; while TEXT_IO.PAGE( HELP_FILE ) = REQ_PAGE loop -- Read a line of help text and fill the remainder of -- the line with blanks. TEXT_IO.GET_LINE( HELP_FILE, FILE_STRING, NO_OF_CHAR ); START_CHAR := NO_OF_CHAR + 1 ; if START_CHAR < HELP_LENGTH then FILE_STRING( START_CHAR..HELP_LENGTH ) := BLNK_STRING( START_CHAR..HELP_LENGTH ) ; end if; -- If size of help message exceeds available number of lines -- then ask for operator conformation before proceeding. if ROW_COUNT = LAST_ROW then -- Request operator confirmation DISPLAY_CONTINUE ; VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( LOW_LEVEL_CRT_FUNCTIONS'( ERASE_SCREEN )) ; ROW_COUNT := 1; end if ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( FILE_STRING( TEXT_OFFSET..FILE_STRING'last ), CURSOR_ADDR'( WRITE_WITH_ADDRESS ) , ROW_COUNT , COLUMN_COUNT ) ; ROW_COUNT := ROW_COUNT + 1; end loop; -- If file does not include help text for the requested menu -- or command then notify the operator. exception when END_ERROR => DISPLAY_ERROR( CANT_FIND_1 & SEARCH_STRING & CANT_FIND_2 ) ; end ; -- Display information message concerning next required -- action to the operator. ROW_COUNT := ROW_COUNT + 1; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( COMMAND_HELP, CURSOR_ADDR'( WRITE_WITH_ADDRESS ) , COMMAND_ROW, COLUMN_COUNT ) ; ROW_COUNT := ROW_COUNT + 1; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( EXIT_HELP, CURSOR_ADDR'( WRITE_WITH_ADDRESS ) , EXIT_ROW, COLUMN_COUNT ) ; end DISPLAY_HELP ; begin -- Open text file containing help commands. TEXT_IO.OPEN( HELP_FILE, TEXT_IO.IN_FILE, FILE_NAME ); -- Display the general help text associated with the current menu. DISPLAY_HELP( MMI_PARAMETERS.MENU_ID'image( MENU )) ; -- Save help icon segment for highlighting. HELP_ICON_SEGMENT := SEGMENT_TO_HIGHLIGHT ; -- Display the help text associated with the specified -- commands until the help icon is chosen. loop SELECTED_CMD := DEFAULT_CMD ; DISPLAY_MENU_AND_GET_COMMAND( MMI_PARAMETERS.CURRENT_MENU, SELECTED_CMD ); -- If help icon was selected then turn help icon segment -- off and exit help mode. if SELECTED_CMD = MMI_PARAMETERS.HELP_CMD then if HELP_ICON_HIGHLIGHTED then GRAPHIC_DRIVER.HILITE_SEGMENT( HELP_ICON_SEGMENT, GKS_SPECIFICATION.NORMAL ) ; end if ; exit ; else -- If help icon segment is not highlighted then highlight -- the segment. if not HELP_ICON_HIGHLIGHTED then GRAPHIC_DRIVER.HILITE_SEGMENT( HELP_ICON_SEGMENT, GKS_SPECIFICATION.HIGHLIGHTED ) ; HELP_ICON_HIGHLIGHTED := true ; end if ; DISPLAY_HELP( MMI_PARAMETERS.COMMAND_TYPE'image( SELECTED_CMD )) ; end if; end loop; -- Erase any text currently on the screen and close the -- help file. VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( LOW_LEVEL_CRT_FUNCTIONS'( ERASE_SCREEN )) ; TEXT_IO.CLOSE( HELP_FILE ); -- If help file is unavailable then notify the operator. exception when STATUS_ERROR | NAME_ERROR => -- Display no help file available message. DISPLAY_ERROR( NO_FILE ); end HELP ; procedure PRESET_ICON_CURSOR ( MENU : in MENU_ID ; COMMAND : in COMMAND_TYPE ) is -- ========================================================== -- Place the cursor on the icon that corresponds to the -- specified command of current menu. -- ========================================================== ICON_POSITION : GRAPHICS_DATA.POINT ; CENTER_WIDTH : constant GRAPHICS_DATA.WC := ( MENU_X_MAX - MENU_X_MIN ) / 2 ; CENTER_HEIGHT : constant GRAPHICS_DATA.WC := ( ICON_BOUNDARY( ICON_ID'first ).UPPER - ICON_BOUNDARY( ICON_ID'first ).LOWER ) / 2 ; begin -- set default icon to help command ICON_POSITION.X := CENTER_WIDTH + 0 ; ICON_POSITION.Y := CENTER_HEIGHT + ICON_BOUNDARY( ICON_ID'first ).LOWER ; -- get the icon id that corresponds to selected command for I in ICON_ID'first..ICON_ID'last loop if COMMAND = MENU_TABLE( MENU, I ).COMMAND then ICON_POSITION.Y := CENTER_HEIGHT + ICON_BOUNDARY( I ).LOWER ; exit ; end if ; end loop ; -- place cursor at icon id GRAPHIC_DRIVER.PLACE_CURSOR( ICON_POSITION ) ; end PRESET_ICON_CURSOR ; procedure REFERENCE_MARKER ( MODE : in GKS_SPECIFICATION.SEGMENT_VISIBILITY ; LOCATION : in GRAPHICS_DATA.POINT ) is -- ========================================================== -- Place the system marker segment at the specified location -- and set the segment visible or invisible. -- ========================================================== LOCATION_CENTER , LOCATION_SIZE : GRAPHICS_DATA.POINT ; MARKER_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME := GRAPHICS_DATA.NULL_SEGMENT ; MARKER_ICON : constant STRING(1..1):= "*"; MARKER_COLOR : constant GRAPHICS_DATA.COLOR_TYPE := GRAPHICS_DATA.PINK ; begin -- check that were not tring to make invisible markers that -- arn't there. if not ( PRIMARY_AVAILABLE and MODE = GKS_SPECIFICATION.INVISIBLE ) then -- all operations occur to primary marker if it is available -- otherwise the action occures to the secondary marker. -- check primary marker status if ok use else use secondary marker if ( PRIMARY_AVAILABLE and MODE = GKS_SPECIFICATION.VISIBLE ) or ( SECONDARY_AVAILABLE and MODE = GKS_SPECIFICATION.INVISIBLE ) then MARKER_SEGMENT := PRIMARY_MARKER_SEGMENT ; else MARKER_SEGMENT := SECONDARY_MARKER_SEGMENT ; end if ; -- determin if segment is to be turned on or off if MODE = GKS_SPECIFICATION.VISIBLE then -- If marker segment doesn't exist then create the segment --if MARKER_SEGMENT = GRAPHICS_DATA.NULL_SEGMENT then LOCATION_CENTER.X := LOCATION.X - ( GRAPHICS_DATA.DEFAULT_CHARACTER_WIDTH / 2 ) ; LOCATION_CENTER.Y := LOCATION.Y + ( GRAPHICS_DATA.DEFAULT_CHARACTER_HEIGHT / 2 ) ; GRAPHIC_DRIVER.LABEL ( MARKER_SEGMENT , LOCATION_SIZE , LOCATION_CENTER , MARKER_ICON , MARKER_COLOR ) ; -- set the new marker segment number if PRIMARY_AVAILABLE then PRIMARY_MARKER_SEGMENT := MARKER_SEGMENT ; PRIMARY_AVAILABLE := False ; else SECONDARY_MARKER_SEGMENT := MARKER_SEGMENT ; SECONDARY_AVAILABLE := False ; end if ; --end if ; else -- set marker visibile mode and move the marker segment --GRAPHIC_DRIVER.SEGMENT_VISIBILITY ( MARKER_SEGMENT , MODE ) ; --GRAPHIC_DRIVER.MOVE ( MARKER_SEGMENT , LOCATION ) ; -- temp fix it here GRAPHIC_DRIVER.DELETE_SEGMENT ( MARKER_SEGMENT ) ; MARKER_SEGMENT := GRAPHICS_DATA.NULL_SEGMENT ; -- end temp fix it if SECONDARY_AVAILABLE then -- primary was set invisible so set available PRIMARY_AVAILABLE := True ; end if ; -- set secondary marker available always SECONDARY_AVAILABLE := True ; end if ; end if ; end REFERENCE_MARKER ; procedure SIGN_ON is -- ========================================================== -- This routine provides initial system start up utilities -- such as clearing the terminal screen, displaying a -- copyright message, etc. -- ========================================================== LINE_1 , LINE_2 , LINE_3 , LINE_4 : STRING ( 1..53 ) ; LINE_5 , LINE_6 : STRING ( 1..55 ) ; begin -- set sign on text if PROTOTYPE_SIGN_ON then LINE_1 := " Welcome to SKETCHER - an Ada* oriented design tool. " ; LINE_2 := "This copyrighted program is the exclusive property of" ; LINE_3 := "SYSCON Corp. Contact John Reddan at (619) 296-0085 " ; LINE_4 := " with questions or problems. " ; else LINE_1 := " Welcome to " ; LINE_2 := " G R A P H I C A d a * D E S I G N E R " ; LINE_3 := " an Ada oriented design tool " ; LINE_4 := " By SYSCON Corp. " ; end if ; LINE_5 := "* Ada is a registered trademark of the U.S. Government," ; LINE_6 := " Ada Joint Program Office. " ; -- Notify user of tool invocation and restricted rights -- erase the crt screen VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " " , FORMAT_FCT'( CLEAR_SCREEN ) , ROW_NO( 1 )) ; -- present program id and intro to user VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( LINE_1 , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 10 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( LINE_2 , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 12 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( LINE_3 , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 14 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( LINE_4 , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 15 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( LINE_5 , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 20 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( LINE_6 , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 21 )) ; end SIGN_ON ; function TRUNCATE_NAME ( USER_NAME : in String ; SPACE_WIDTH : in Natural ; PARAMS_SYMBOL : in Boolean := False ) return STRING is -- ========================================================== -- Truncate the user name to a width which will fit into -- the user specified space width, and return the -- truncate name. -- ========================================================== GOOD_SIZE : Natural := 0 ; CALC_FACTOR : constant Natural := 10 ; FIRST_CHAR : constant Natural := USER_NAME'first ; LAST_CHAR : Integer := USER_NAME'last ; NAME_WIDTH , ADJUSTED_SPACE , SPACE_CHAR_SIZE : Natural ; ADJUSTED_OFFSET : constant Natural := GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET / CALC_FACTOR ; begin -- find the last good character in the user name, -- exits when two contigous spaces are found. for I in USER_NAME'first .. USER_NAME'last-1 loop exit when USER_NAME ( I ) = ' ' and USER_NAME ( I+1 ) = ' ' ; GOOD_SIZE := I + 1 ; end loop ; NAME_WIDTH := ( ( USER_NAME'last - USER_NAME'first ) + 1 ) * ADJUSTED_OFFSET ; ADJUSTED_SPACE := SPACE_WIDTH / CALC_FACTOR ; SPACE_CHAR_SIZE := ADJUSTED_SPACE / ADJUSTED_OFFSET ; if NAME_WIDTH > ADJUSTED_SPACE then if SPACE_CHAR_SIZE = 0 then SPACE_CHAR_SIZE := 1 ; end if ; LAST_CHAR := FIRST_CHAR + SPACE_CHAR_SIZE - 1 ; end if ; if PARAMS_SYMBOL then -- adjust last char shortened by params symbols size LAST_CHAR := LAST_CHAR - GRAPHICS_DATA.PARAMS_DECL'Length ; -- double check the size of last char if LAST_CHAR < FIRST_CHAR then LAST_CHAR := FIRST_CHAR ; end if ; -- check if calced width is longer than name width if so fix it if ( ( LAST_CHAR - FIRST_CHAR ) + 1 ) > GOOD_SIZE then LAST_CHAR := FIRST_CHAR + GOOD_SIZE - 1 ; end if ; -- return the adjusted user name return USER_NAME( FIRST_CHAR .. LAST_CHAR ) & GRAPHICS_DATA.PARAMS_DECL(1) & GRAPHICS_DATA.PARAMS_DECL(2) ; else -- check if calced width is longer than name width if so fix it if ( ( LAST_CHAR - FIRST_CHAR ) + 1 ) > GOOD_SIZE then LAST_CHAR := FIRST_CHAR + GOOD_SIZE - 1 ; end if ; -- return the adjusted user name return USER_NAME( FIRST_CHAR .. LAST_CHAR ) ; end if ; exception -- on any error trunc to first character only and report to trace when others => return USER_NAME( FIRST_CHAR .. FIRST_CHAR ) ; TRACE_PKG.TRACE ( " exception raised in UTILITIES.TRUNCATE_NAME" ) ; end TRUNCATE_NAME ; function VALID_DRAWING_BOUNDARIES ( LOCATION : GRAPHICS_DATA.POINT ) return Boolean is -- ============================================================ -- determin if a point can be drawn within the drawing boundry -- area that is defined with label buffer zone for move and -- resize functions on entities. -- ============================================================ BOUNDRY : constant GRAPHICS_DATA.RECTANGLE := ( X => ( MIN => GRAPHICS_DATA.MIN_WC + GRAPHICS_DATA.IMPORT_EXPORT_X_OFFSET + GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET , MAX => GRAPHICS_DATA.MAX_WC - GRAPHICS_DATA.LABEL_MAX_LENGTH ) , Y => ( MIN => GRAPHICS_DATA.MIN_WC , MAX => GRAPHICS_DATA.MAX_WC - GRAPHICS_DATA.CHARACTER_HEIGHT_OFFSET ) ) ; begin -- VALID_DRAWING_BOUNDRIES if LOCATION.X <= BOUNDRY.X.MAX and LOCATION.X >= BOUNDRY.X.MIN and LOCATION.Y <= BOUNDRY.Y.MAX and LOCATION.Y >= BOUNDRY.Y.MIN then return True ; else return False ; end if ; end VALID_DRAWING_BOUNDARIES ; end UTILITIES ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --pdl_gen_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 22 November 1985 by JB with TREE_IO ; package PDL_GEN is ------------------------------------------------------------------------ -- -- This package will create the Ada PDL corresponding to the -- information stored in the current graph tree (as stored -- in TREE_DATA). ------------------------------------------------------------------------ --------------------------------------------------------------------- -- -- The following are the parameters controlling PDL generation. -- --------------------------------------------------------------------- TRACE_GENERATION : BOOLEAN := False ; -- TRUE; -- Trace the PDL Generation process with an emphasis on -- tracking the nodes traversed. INCLUDE_SUPPORT_PACKAGE : BOOLEAN := True ; -- Indicates if the design support package should be included -- in the PDL output file or not. WRITE_PDL_TO_SCREEN : BOOLEAN := True ; -- Indicates if the PDL should be written to the screen -- as the PDL output file is being generated. INDENTATION_INCREMENT : NATURAL range 1..8 := 3; -- The number of spaces indented for each nesting level. MAX_INDENTATION : NATURAL range 0..40 := INDENTATION_INCREMENT*10; -- The greatest amount of indentation allowed, should always be -- an multiple of the INDENTATION_INCREMENT -- NOTE : Currently not used, a Pretty Printer should be used instead. MAX_LINE_LENGTH : NATURAL range 50..256 := 80; -- The longest line output in PDL generation -- NOTE : Currently not used, a Pretty Printer should be used instead. UNTRANSLATABLE_CODE_COMMENT_SYMBOL : CHARACTER := '*'; -- The character appended to a standard Ada comment symbol -- to denote an untranslatable code statement (for example, -- a virtual package declaration). -- --------------------------------------------------------------------- -- The following procedure is invoked to cause the PDL generation -- to occur --------------------------------------------------------------------- procedure GENERATE_PDL ( PDL_FILE_NAME : in TREE_IO.FILENAME_TYPE ) ; -- -- This procedure walks the current Graph Tree and emits the -- corresponding Ada PDL in the file designated by the user. -- The procedure expects that PDL_FILE is an handle on -- an open file into which the PDL should be placed. The -- file will be not be closed by GENERATE_PDL. -- end PDL_GEN; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --pdl_gen_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 24 January 1986 by JR -> 'withs' for refered units only -- version 17 January 1986 by JR -- version 7 January 1986 by JR -- version 10 December 1985 by JR with TEXT_IO ; with GRAPHICS_DATA ; use GRAPHICS_DATA ; with TREE_DATA ; use TREE_DATA ; with TREE_OPS ; use TREE_OPS ; with UTIL_FOR_TREE ; with UTILITIES ; use UTILITIES ; with VIRTUAL_TERMINAL_INTERFACE ; use VIRTUAL_TERMINAL_INTERFACE ; package body PDL_GEN is --------------------------------------------------------------------------- -- The package performing Ada PDL generation includes routines to -- generate PDL by walking the tree which contains the information -- describing the OODD currently being edited. A two pass PDL -- generation algorithm is implemented by using two subprograms, one -- to generate the specifications for the PDL and the other to -- generate the bodies for the PDL. Both subprograms use a recursive -- descent approach to generate the PDL, wherein each subprogram will -- perform the code generation by writing the PDL appropriate for the -- current node and using recursive invocations of itself to process -- its child nodes. --------------------------------------------------------------------------- ------------------------------------------------------------------------ -- declare the local variables ------------------------------------------------------------------------ BLANK_LINE : constant STRING (1..256) := (others => ' ') ; -- indicator if a tree node has been declared yet DECLARED : array ( 1 .. MAX_TREE_NODES ) of BOOLEAN; -- pdl file name extention FILENAME_EXTENSION : constant TREE_IO.EXTENSION_TYPE := ".PDL" ; -- the current indentation level INDENTATION : NATURAL := 0; -- the output line buffer LINE : STRING (1..256); -- the line length of the current line LINE_LENGTH : NATURAL := 0; -- the screen output line buffer and column counter SCREEN_LINE : STRING (1..256) := BLANK_LINE ; LAST_ROW : constant VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE := VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE'last - 3 ; FIRST_COLUMN : constant VIRTUAL_TERMINAL_INTERFACE.COLUMN_TYPE := 1 ; STRING_END : NATURAL := 0 ; NEW_END : NATURAL := 0 ; MAXIMUM_COL : constant NATURAL := 80 ; type DISPLAY_STRING is ( DISPLAY_LATER, DISPLAY_NOW ) ; -- the nesting levels of the specifications NESTING_LEVEL : NATURAL := 0 ; -- the output file for the PDL PDL_FILE : TEXT_IO.FILE_TYPE; -- a count of the number of times indentation was requested -- when already at the max indentation level TIMES_BEYOND_MAX_INDENT : NATURAL := 0; UNTRANS : STRING (1..1) := ( 1 => UNTRANSLATABLE_CODE_COMMENT_SYMBOL ) ; ------------------------------------------------------------------------ -- procedures to write the PDL with ------------------------------------------------------------------------ -- These procedures will provide the means of writing the -- generated PDL to the selected output file. If parallel -- output is desired (i.e., to the screen also), extra -- 'PUT' statements would be added here. These procedures -- also insure that MAX_LINE_LENGTH is not exceeded. procedure PUT_TO_SCREEN ( MESSAGE : in STRING ; WRITE_TO_SCREEN : in DISPLAY_STRING ) is -- Place the received string on the screen output message and -- write the string to the screen if boolean is set. begin -- Append received message to screen output string ; NEW_END := STRING_END + MESSAGE'length ; if NEW_END <= SCREEN_LINE'last then STRING_END := STRING_END + 1 ; SCREEN_LINE( STRING_END..NEW_END ) := MESSAGE ; STRING_END := NEW_END ; end if ; -- If requested then write string to screen and clear string -- and column counter. if WRITE_TO_SCREEN = DISPLAY_NOW then if STRING_END < MAXIMUM_COL then STRING_END := STRING_END + 1 ; SCREEN_LINE( STRING_END..MAXIMUM_COL ) := BLANK_LINE( STRING_END..MAXIMUM_COL ) ; end if ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( SCREEN_LINE( SCREEN_LINE'first..MAXIMUM_COL ), VIRTUAL_TERMINAL_INTERFACE.WRITE_WITH_ADDRESS , LAST_ROW , FIRST_COLUMN ) ; VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS( VIRTUAL_TERMINAL_INTERFACE.SCROLL_UP ) ; SCREEN_LINE := BLANK_LINE ; STRING_END := 0 ; end if ; end PUT_TO_SCREEN ; procedure INITIALIZE_SCREEN_DISPLAY is -- Clear the screen of any text and set variables required -- for screen output. begin VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( LOW_LEVEL_CRT_FUNCTIONS'( ERASE_SCREEN )) ; VIRTUAL_TERMINAL_INTERFACE.SCROLLING_REGION ( VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE( 1 ), LAST_ROW ) ; SCREEN_LINE := BLANK_LINE ; STRING_END := 0 ; end INITIALIZE_SCREEN_DISPLAY ; procedure TERMINATE_SCREEN_DISPLAY is -- Erase the screen after operator input is received. begin -- Reset the scrolling region to the entire screen. VIRTUAL_TERMINAL_INTERFACE.SCROLLING_REGION ( VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE'first, VIRTUAL_TERMINAL_INTERFACE.ROW_TYPE'last ) ; -- display continue message UTILITIES.DISPLAY_CONTINUE ; VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( LOW_LEVEL_CRT_FUNCTIONS'( ERASE_SCREEN )) ; end TERMINATE_SCREEN_DISPLAY ; procedure WRITE (MESSAGE: in STRING) is -- Write the MESSAGE to the PDL output file, and allow continuation -- on the same line. begin -- indent if not already done if LINE_LENGTH < INDENTATION then if LINE_LENGTH > 0 then LINE(LINE_LENGTH..INDENTATION) := BLANK_LINE(LINE_LENGTH..INDENTATION); else TEXT_IO.PUT (PDL_FILE,BLANK_LINE(1..INDENTATION)); if WRITE_PDL_TO_SCREEN then PUT_TO_SCREEN ( BLANK_LINE(1..INDENTATION), DISPLAY_LATER ) ; end if ; end if; LINE_LENGTH := INDENTATION; end if; -- write the message out if (LINE_LENGTH + MESSAGE'last) > MAX_LINE_LENGTH then -- break the line TEXT_IO.PUT (PDL_FILE,MESSAGE); if WRITE_PDL_TO_SCREEN then PUT_TO_SCREEN ( MESSAGE, DISPLAY_LATER ) ; end if ; else TEXT_IO.PUT (PDL_FILE,MESSAGE); LINE_LENGTH := LINE_LENGTH + MESSAGE'last; if WRITE_PDL_TO_SCREEN then PUT_TO_SCREEN ( MESSAGE, DISPLAY_LATER ) ; end if ; end if; end WRITE; procedure WRITE_LINE (MESSAGE: in STRING) is -- Write the MESSAGE to the PDL output file, and then begin a new -- line begin -- indent if not already done if LINE_LENGTH < INDENTATION then if LINE_LENGTH > 0 then TEXT_IO.PUT (PDL_FILE,BLANK_LINE(LINE_LENGTH..INDENTATION)); if WRITE_PDL_TO_SCREEN then PUT_TO_SCREEN ( BLANK_LINE(LINE_LENGTH..INDENTATION), DISPLAY_LATER ) ; end if ; else TEXT_IO.PUT (PDL_FILE,BLANK_LINE(1..INDENTATION)); if WRITE_PDL_TO_SCREEN then PUT_TO_SCREEN ( BLANK_LINE(1..INDENTATION), DISPLAY_LATER ) ; end if ; end if; LINE_LENGTH := INDENTATION; end if; -- write the message out if (LINE_LENGTH + MESSAGE'last) > MAX_LINE_LENGTH then -- break the line TEXT_IO.PUT_LINE (PDL_FILE,MESSAGE); if WRITE_PDL_TO_SCREEN then PUT_TO_SCREEN ( MESSAGE, DISPLAY_NOW ) ; end if ; else TEXT_IO.PUT_LINE (PDL_FILE,MESSAGE); if WRITE_PDL_TO_SCREEN then PUT_TO_SCREEN ( MESSAGE, DISPLAY_NOW ) ; end if ; end if; -- reset the line length LINE_LENGTH := 0; end WRITE_LINE; procedure NEW_LINE is begin LINE_LENGTH := 0; TEXT_IO.NEW_LINE (PDL_FILE); if WRITE_PDL_TO_SCREEN then PUT_TO_SCREEN ( " ", DISPLAY_NOW ) ; end if ; end NEW_LINE; ------------------------------------------------------------------------ -- procedures to provide execution Trace ------------------------------------------------------------------------ procedure TRACE (MESSAGE: in STRING) is begin if TRACE_GENERATION then TEXT_IO.PUT_LINE (PDL_FILE,MESSAGE); end if; end TRACE; ------------------------------------------------------------------------ -- procedures to control indentation ------------------------------------------------------------------------ procedure INCREMENT_INDENTATION is -- This procedure increments the INDENTATION level up to -- the MAX_LINE_LENGTH begin -- check if already at maximum indentation if INDENTATION = MAX_INDENTATION then TIMES_BEYOND_MAX_INDENT := TIMES_BEYOND_MAX_INDENT + 1; else -- increment the indentation and limit it to the maximum INDENTATION := INDENTATION + INDENTATION_INCREMENT; if INDENTATION > MAX_INDENTATION then INDENTATION := MAX_INDENTATION; TIMES_BEYOND_MAX_INDENT := 1; end if; end if; end INCREMENT_INDENTATION; procedure DECREMENT_INDENTATION is -- This procedure decrements the INDENTATION level down -- to zero (but not beyond). begin -- check if decrementing will produce an illegal indentation level if INDENTATION < INDENTATION_INCREMENT then INDENTATION := 0; -- check if at maximum indendation more than one elsif INDENTATION = MAX_INDENTATION then TIMES_BEYOND_MAX_INDENT := TIMES_BEYOND_MAX_INDENT - 1; if TIMES_BEYOND_MAX_INDENT = 0 then INDENTATION := INDENTATION - INDENTATION_INCREMENT; end if; else -- no special conditions, just decrement the indentation level INDENTATION := INDENTATION - INDENTATION_INCREMENT; end if; end DECREMENT_INDENTATION; ------------------------------------------------------------------------ -- The procedure to write the Support Package ------------------------------------------------------------------------ procedure WRITE_SUPPORT_PACKAGE is -- This procedure writes the Support Package to the -- PDL output file if the option has been requested. begin NEW_LINE ; WRITE_LINE ("package SUPPORT_PACKAGE is ") ; WRITE_LINE (" type TBD_TYPE is (TBD) ;") ; WRITE_LINE (" TBD_OBJECT : TBD_TYPE ;") ; WRITE_LINE (" TBD_PARAMETERS : TBD_TYPE ; ") ; WRITE_LINE (" TBD_TIME : DURATION ; ") ; WRITE_LINE (" TBD_CONDITION : BOOLEAN ;") ; WRITE_LINE ("end SUPPORT_PACKAGE ;") ; NEW_LINE ; end WRITE_SUPPORT_PACKAGE ; ------------------------------------------------------------------------ -- The procedures to transform Tree data to printable form ------------------------------------------------------------------------ function EXTRACT (NAME: in STRING) return STRING is -- This procedure removes the unused characters from -- (i.e., blanks) from strings for printing ACTUAL_LENGTH : INTEGER := 0; begin for I in reverse NAME'range loop if NAME(I) /= ' ' then -- found end of used part of string ACTUAL_LENGTH := I; exit; end if; end loop; if ACTUAL_LENGTH > 0 then return NAME(1..ACTUAL_LENGTH); else return ""; end if; end EXTRACT; function GET_FULL_NAME (NODE: in TREE_NODE_ACCESS_TYPE) return STRING is -- This function returns the full name of the specified node. -- It is primarily used in producing the code for subprogram -- and task entry point calls. IN_NODE : TREE_NODE_ACCESS_TYPE := NODE ; function GET_PARENT_NAMES (NODE: in TREE_NODE_ACCESS_TYPE) return STRING is -- Get the names of the parents and place a dot ('.') after -- each one. begin if NODE = NULL_POINTER or NODE = ROOT_NODE then return "" ; else return GET_PARENT_NAMES(TREE(NODE).PARENT) & EXTRACT(TREE(NODE).NAME) & "." ; end if ; end GET_PARENT_NAMES ; begin -- if IN_NODE belongs to an exported entity, check if is connected -- to an inner level. begin if TREE( IN_NODE).NODE_TYPE in EXPORTED_PROCEDURE .. EXPORTED_ENTRY_POINT then while TREE( IN_NODE ).CONNECTEE /= NULL_POINTER loop IN_NODE := TREE( IN_NODE ).CONNECTEE ; end loop ; end if ; exception when others => null ; end ; -- Return the name of the current node appended to the name of -- all parents of the current node. If the current node is -- an import, then ignore its parent (since it is a withed unit). if TREE(IN_NODE).NODE_TYPE in IMPORTED_PROCEDURE .. IMPORTED_FUNCTION then return EXTRACT( TREE(IN_NODE).NAME ) ; else return GET_PARENT_NAMES(TREE(IN_NODE).PARENT) & EXTRACT(TREE(IN_NODE).NAME) ; end if ; end GET_FULL_NAME ; procedure WRITE_PROLOGUE (PRO_PTR : in PROLOGUE_NODE_ACCESS_TYPE) is -- This procedure writes the Prologue for a unit if -- it exists. LENGTH : NATURAL ; NULL_PROLOGUE_LINE : PROLOGUE_LINE := (others => ' ') ; begin if PRO_PTR /= NULL_POINTER then for I in 1 .. PROLOGUE_COUNT loop if PROLOGUE( PRO_PTR ).DATA( I ) = NULL_PROLOGUE_LINE then exit ; else -- only write the portion of the Prologue line -- actually used. LENGTH := TREE_DATA.PROLOGUE_LINE_SIZE ; for J in reverse 2 .. TREE_DATA.PROLOGUE_LINE_SIZE loop if PROLOGUE(PRO_PTR).DATA(I)(J) = ' ' then LENGTH := J - 1; else exit ; end if ; end loop ; WRITE_LINE ("--" & UNTRANS & " " & PROLOGUE(PRO_PTR).DATA(I)(1 .. LENGTH) ) ; end if ; end loop ; end if ; end WRITE_PROLOGUE ; procedure WRITE_WITHS_OF_VISIBLE_UNITS (NODE: in TREE_NODE_ACCESS_TYPE) is -- This procedure writes the 'WITH' statements of the units which -- are visible by the basis of being 'within view' on the graph -- depicting the OODD. This is effectively all top-level units -- except the one currently being written. PTR : LIST_NODE_ACCESS_TYPE; SUBTREE_NODE : TREE_NODE_ACCESS_TYPE ; TREE_PTR : TREE_NODE_ACCESS_TYPE; WALK_STATE : TREE_OPS.WALK_STATE_TYPE ; function CHECK_FOR_REFERENCE ( FROM: in TREE_NODE_ACCESS_TYPE ; TO: in TREE_NODE_ACCESS_TYPE ) return BOOLEAN is -- This function checks if their are any references (call -- or visibility connections) from the FROM node to the TO -- node. CONNECTEE : TREE_NODE_ACCESS_TYPE ; LPTR : LIST_NODE_ACCESS_TYPE ; begin -- get the list head of the connection type to be processed case TREE( FROM ).NODE_TYPE is when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE | TYPE_PROCEDURE | TYPE_FUNCTION | TYPE_TASK => LPTR := TREE( FROM ).DATA_CONNECT_LIST ; when TYPE_BODY => LPTR := TREE( FROM ).CALLEE_LIST ; when others => LPTR := NULL_POINTER ; end case ; -- process any non-null connection lists while LPTR /= NULL_POINTER loop -- check for a reference to the TO node by seeing if the -- connectee is in the subtree the TO node defines CONNECTEE := TREE( LIST(LPTR).ITEM ).CONNECTEE ; if TO = UTIL_FOR_TREE.LOWEST_COMMON_PARENT ( TO, CONNECTEE ) then -- found a reference return True ; end if ; LPTR := LIST( LPTR ).NEXT ; end loop ; return False ; -- no reference found exception when others => return False ; -- no correct reference(s) found end CHECK_FOR_REFERENCE ; begin -- handle only top-level units if TREE( NODE ).PARENT = ROOT_NODE then PTR := TREE( ROOT_NODE ).CONTAINED_ENTITY_LIST ; while PTR /= NULL_POINTER loop TREE_PTR := LIST( PTR ).ITEM ; if TREE_PTR /= NODE then -- The TREE_PTR is pointing to a different top level -- unit (node). Check if their are any references to -- it in the subtree defined by the current NODE. -- walk the subtree checking for references TREE_OPS.START_TREE_WALK ( NODE, WALK_STATE ) ; loop -- get the tree node to be processed TREE_OPS.TREE_WALK ( WALK_STATE, SUBTREE_NODE ) ; exit when SUBTREE_NODE = NULL_POINTER ; -- if there is a reference then write the 'with' -- statement and move on to the next top level unit if CHECK_FOR_REFERENCE ( FROM => SUBTREE_NODE, TO => TREE_PTR ) then WRITE_LINE ("with " & EXTRACT(TREE(TREE_PTR).NAME) & " ;") ; exit ; end if ; end loop ; end if ; PTR := LIST( PTR ).NEXT ; end loop ; end if ; end WRITE_WITHS_OF_VISIBLE_UNITS ; ------------------------------------------------------------------------ -- The procedure to emit the PDL for the specifications ------------------------------------------------------------------------ procedure EMIT_SPECS (NODE: in TREE_NODE_ACCESS_TYPE) is -- This procedure emits the PDL for the spec of the current -- Tree node, and recursively invokes itself for contained -- entities of the current node. PTR : LIST_NODE_ACCESS_TYPE; TREE_PTR : TREE_NODE_ACCESS_TYPE; begin TRACE (" starting EMIT_SPECS " & INTEGER'image(NODE) & " (tree) "); -- Check if the current NODE is valid. if NODE = NULL_POINTER then return; -- Skip this Tree NODE if it has already been declared. elsif not DECLARED(NODE) then NESTING_LEVEL := NESTING_LEVEL + 1 ; case TREE(NODE).NODE_TYPE is when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE => NEW_LINE ; -- Scan the IMPORTED_LIST and write the 'with's. PTR := TREE(NODE).IMPORTED_LIST; while PTR /= NULL_POINTER loop -- Write the with statement. TREE_PTR := LIST(PTR).ITEM; WRITE_LINE ("with " & EXTRACT(TREE(TREE_PTR).NAME) & " ;"); -- Mark the node as declared. DECLARED(TREE_PTR) := TRUE; -- Process the next imported item. PTR := LIST(PTR).NEXT; end loop; -- Write the support package if not nested and the -- the user has requested it. if NESTING_LEVEL = 1 and INCLUDE_SUPPORT_PACKAGE then WRITE_LINE ("with SUPPORT_PACKAGE ;") ; WRITE_LINE ("use SUPPORT_PACKAGE ;") ; end if ; -- If this declaration is generic, write the generic statement. if TREE(NODE).GENERIC_STATUS = GENERIC_DECLARATION then WRITE_LINE ("generic"); end if; -- Write the 'start' of the (virtual) package. WRITE ("package " & EXTRACT(TREE(NODE).NAME) & " is" ); if TREE(NODE).NODE_TYPE = TYPE_VIRTUAL_PACKAGE then WRITE (" --" & UNTRANS & " VIRTUAL PACKAGE"); end if; -- If this is a generic instantiation then if TREE(NODE).GENERIC_STATUS = GENERIC_INSTANTIATION then -- complete the declaration. WRITE_LINE (" new " & EXTRACT(TREE(NODE).CU_INSTANTIATED) & " ;"); -- Write the prologue. INCREMENT_INDENTATION; WRITE_PROLOGUE ( TREE(NODE).PROLOGUE_PTR ) ; DECREMENT_INDENTATION; else -- Write a non generic declaration. NEW_LINE; INCREMENT_INDENTATION; -- Write the prologue. WRITE_PROLOGUE ( TREE(NODE).PROLOGUE_PTR ) ; -- Scan the EXPORTED_LIST for visible types, objects, -- and exceptions. PTR := TREE(NODE).EXPORTED_LIST; while PTR /= NULL_POINTER loop if TREE( LIST(PTR).ITEM ).NODE_TYPE in EXPORTED_TYPE .. EXPORTED_EXCEPTION then EMIT_SPECS (LIST(PTR).ITEM); end if ; PTR := LIST(PTR).NEXT; end loop; -- Scan the EXPORTED_LIST for remaining items, that is -- packages, subprograms, and tasks. PTR := TREE(NODE).EXPORTED_LIST; while PTR /= NULL_POINTER loop -- Previously declared items are automatically skipped. EMIT_SPECS (LIST(PTR).ITEM); PTR := LIST(PTR).NEXT; end loop; -- Write the 'end' of the package specification. DECREMENT_INDENTATION; WRITE ("end " & EXTRACT(TREE(NODE).NAME) & " ;" ); if TREE(NODE).NODE_TYPE = TYPE_VIRTUAL_PACKAGE then WRITE (" --" & UNTRANS & " VIRTUAL PACKAGE"); end if; NEW_LINE ; end if; when TYPE_PROCEDURE => NEW_LINE ; -- Write the support package if not nested and the -- the user has requested it. if NESTING_LEVEL = 1 and INCLUDE_SUPPORT_PACKAGE then WRITE_LINE ("with SUPPORT_PACKAGE ;") ; WRITE_LINE ("use SUPPORT_PACKAGE ;") ; end if ; -- If this declaration is generic, write the generic statement. if TREE(NODE).GENERIC_STATUS = GENERIC_DECLARATION then WRITE_LINE ("generic"); end if; -- Write the subprogram declaration including the name. WRITE ("procedure " & EXTRACT(TREE(NODE).NAME)); -- If this is a generic instantiation if TREE(NODE).GENERIC_STATUS = GENERIC_INSTANTIATION then -- Complete the generic instantiation. WRITE (" is new " & EXTRACT(TREE(NODE).CU_INSTANTIATED)); -- Generic actual parameters currently not handled. else -- If the subprogram has calling parameters then -- write them. if TREE(NODE).HAS_PARAMETERS then WRITE (" (HAS_PARAMETERS: TBD_TYPE)"); end if; end if ; -- Write the end of the procedure declaration. WRITE_LINE (" ;"); -- Write the prologue. INCREMENT_INDENTATION ; WRITE_PROLOGUE ( TREE(NODE).PROLOGUE_PTR ) ; DECREMENT_INDENTATION ; when TYPE_FUNCTION => NEW_LINE ; -- Write the support package if not nested and the -- the user has requested it. if NESTING_LEVEL = 1 and INCLUDE_SUPPORT_PACKAGE then WRITE_LINE ("with SUPPORT_PACKAGE ;") ; WRITE_LINE ("use SUPPORT_PACKAGE ;") ; end if ; -- If this declaration is generic, write the generic statement. if TREE(NODE).GENERIC_STATUS = GENERIC_DECLARATION then -- Write the generic declaration WRITE_LINE ("generic"); end if; -- Write the function declaration including the name. WRITE ("function " & EXTRACT(TREE(NODE).NAME)); -- If this is a generic instantiation if TREE(NODE).GENERIC_STATUS = GENERIC_INSTANTIATION then -- then complete the instantiation. WRITE (" is new " & EXTRACT(TREE(NODE).CU_INSTANTIATED)); -- Generic actual parameters currently not handled. else -- If the function has calling parameters then write them. if TREE(NODE).HAS_PARAMETERS then WRITE (" (HAS_PARAMETERS: TBD_TYPE)"); end if; -- Write the return part (not needed for generic inst.). WRITE (" return TBD_TYPE"); end if ; -- Write the end of the function declaration. WRITE_LINE (" ;"); -- Write the prologue. INCREMENT_INDENTATION ; WRITE_PROLOGUE ( TREE(NODE).PROLOGUE_PTR ) ; DECREMENT_INDENTATION ; when TYPE_TASK => NEW_LINE ; -- Write the task declarative statement. WRITE_LINE ("task " & EXTRACT(TREE(NODE).NAME) & " is"); INCREMENT_INDENTATION; -- Write the prologue. WRITE_PROLOGUE ( TREE(NODE).PROLOGUE_PTR ) ; -- Scan the ENTRY_LIST for the entry points. PTR := TREE(NODE).ENTRY_LIST; while PTR /= NULL_POINTER loop -- Write an entry statement for each entry found. TREE_PTR := LIST(PTR).ITEM; WRITE ("entry " & EXTRACT(TREE(TREE_PTR).NAME)); -- Write calling parameters if they exist. if TREE(TREE_PTR).WITH_PARAMETERS then WRITE (" (HAS_PARAMETERS: TBD_TYPE)"); end if; WRITE_LINE (" ;"); -- Mark the node as declared. DECLARED(TREE_PTR) := TRUE; -- Process the next imported item. PTR := LIST(PTR).NEXT; end loop; -- Write the 'end' of the task declaration. DECREMENT_INDENTATION; WRITE_LINE ("end " & EXTRACT(TREE(NODE).NAME) & " ;" ); when TYPE_BODY => -- No body code placed in the specs. null; when EXPORTED_PROCEDURE .. EXPORTED_EXCEPTION => -- If this Exported declaration is Connected to -- the an exported item of a contained package, then -- all the exported items of that package -- must be made visible. TREE_PTR := TREE(NODE).CONNECTEE; if TREE_PTR /= NULL_POINTER then -- If connected to another export then declare the -- Parent. if (TREE(TREE_PTR).NODE_TYPE in EXPORTED_PROCEDURE .. EXPORTED_EXCEPTION) or TREE(TREE_PTR).NODE_TYPE = TYPE_ENTRY_POINT then EMIT_SPECS (TREE(TREE_PTR).PARENT); else -- Write declaration using actual declaration. EMIT_SPECS (TREE_PTR); end if; else -- Process all non-connected exports. case TREE(NODE).NODE_TYPE is when EXPORTED_PROCEDURE => NEW_LINE ; -- Write the procedure declaration. WRITE_LINE ("procedure " & EXTRACT(TREE(NODE).NAME) & " ;" ); when EXPORTED_FUNCTION => NEW_LINE ; -- Write the function declaration. WRITE_LINE ("function " & EXTRACT(TREE(NODE).NAME) & " return TBD_TYPE ;" ); when EXPORTED_TYPE => -- Write the type declaration. WRITE_LINE ("type " & EXTRACT(TREE(NODE).NAME) & " is new TBD_TYPE ;"); when EXPORTED_OBJECT => -- Write the object declaration. WRITE_LINE (EXTRACT(TREE(NODE).NAME) & " : TBD_TYPE ;"); when EXPORTED_EXCEPTION => -- Write the exception declaration. WRITE_LINE (EXTRACT(TREE(NODE).NAME) & " : exception ;"); when others => null; end case; -- Mark valid CONNECTEEs as declared. if TREE_PTR /= NULL_POINTER then DECLARED(TREE_PTR) := TRUE; end if; end if; when others => -- Should not occur here! Send an error message to the -- user an attempt to continue. NEW_LINE; WRITE_LINE ("*** Erroneous construct detected in Tree ***"); NEW_LINE; end case; -- Mark the current NODE as declared. DECLARED(NODE) := TRUE; -- Reset the nesting level. NESTING_LEVEL := NESTING_LEVEL - 1 ; end if; end EMIT_SPECS; ------------------------------------------------------------------------ -- The procedure to emit the PDL for the bodies ------------------------------------------------------------------------ procedure EMIT_BODIES (NODE: in TREE_NODE_ACCESS_TYPE) is -- This procedure emits the PDL for the body of the current -- Tree node, and recursively invokes itself for contained -- entities of the current node. CONN_PTR : TREE_NODE_ACCESS_TYPE; FIRST : BOOLEAN; PTR : LIST_NODE_ACCESS_TYPE; TREE_PTR : TREE_NODE_ACCESS_TYPE; begin TRACE (" starting EMIT_BODIES " & INTEGER'image(NODE) & " (tree) "); -- check if NODE is valid if NODE = NULL_POINTER then return; end if; -- Increment the nesting level to show inside a body. NESTING_LEVEL := NESTING_LEVEL + 1 ; case TREE(NODE).NODE_TYPE is when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE => -- Skip this node if it is a Generic Instantiation. if TREE(NODE).GENERIC_STATUS /= GENERIC_INSTANTIATION then -- If the package is not already declared then declare it now. if not DECLARED(NODE) then EMIT_SPECS (NODE); end if; NEW_LINE ; -- Write the 'WITH' statements of visible units. WRITE_WITHS_OF_VISIBLE_UNITS ( NODE ) ; -- Write the 'start' of the package body. WRITE ("package body " & EXTRACT(TREE(NODE).NAME) & " is" ); if TREE(NODE).NODE_TYPE = TYPE_VIRTUAL_PACKAGE then WRITE (" --" & UNTRANS & " VIRTUAL PACKAGE"); end if; NEW_LINE; INCREMENT_INDENTATION; -- Write the prologue. WRITE_PROLOGUE ( TREE(NODE).PROLOGUE_PTR ) ; -- Scan the DATA_CONNECT_LIST and write the 'use's. PTR := TREE(NODE).DATA_CONNECT_LIST ; while PTR /= NULL_POINTER loop WRITE_LINE ("use " & EXTRACT(TREE(TREE(LIST(PTR).ITEM).CONNECTEE).NAME) & " ;") ; PTR := LIST(PTR).NEXT ; end loop ; -- Scan the CONTAINED_ENTITY_LIST for undeclared components, -- processing generic declarations in the first pass, and -- all others in the second pass. PTR := TREE(NODE).CONTAINED_ENTITY_LIST; while PTR /= NULL_POINTER loop begin if TREE( LIST(PTR).ITEM ).NODE_TYPE in TYPE_PACKAGE ..TYPE_FUNCTION and then TREE( LIST(PTR).ITEM ).GENERIC_STATUS = GENERIC_DECLARATION and then ( not DECLARED (LIST(PTR).ITEM) ) then EMIT_SPECS (LIST(PTR).ITEM); end if; exception when others => null ; end ; PTR := LIST(PTR).NEXT; end loop; -- Loop and process the non-declared entities which are not -- generic declarations. PTR := TREE(NODE).CONTAINED_ENTITY_LIST; while PTR /= NULL_POINTER loop if not DECLARED (LIST(PTR).ITEM) then EMIT_SPECS (LIST(PTR).ITEM); end if; PTR := LIST(PTR).NEXT; end loop; -- Scan the EXPORTED_LIST for visible subprograms and -- packages which are not connected to other entities -- and hence should be declared as 'separate' PTR := TREE(NODE).EXPORTED_LIST ; while PTR /= NULL_POINTER loop TREE_PTR := LIST(PTR).ITEM ; if TREE(TREE_PTR).NODE_TYPE in EXPORTED_PROCEDURE .. EXPORTED_FUNCTION and then TREE(TREE_PTR).CONNECTEE = NULL_POINTER then if TREE(TREE_PTR).NODE_TYPE = EXPORTED_PROCEDURE then -- The exported procedure declaration is not connected -- to an actual declaration, so no body will be -- generated. Make the body a subunit (separate). NEW_LINE ; WRITE_LINE ("procedure " & EXTRACT(TREE(TREE_PTR).NAME) & " is separate ;" ); else -- exported function -- The exported function declaration is not connected -- to an actual declaration, so no body will be -- generated. Make the body a subunit (separate). NEW_LINE ; WRITE_LINE ("function " & EXTRACT(TREE(TREE_PTR).NAME) & " return TBD_TYPE is separate ;" ); end if ; end if ; PTR := LIST(PTR).NEXT ; end loop ; -- Scan the CONTAINED_ENTITY_LIST and write the nested -- components. PTR := TREE(NODE).CONTAINED_ENTITY_LIST; while PTR /= NULL_POINTER loop EMIT_BODIES (LIST(PTR).ITEM); PTR := LIST(PTR).NEXT; end loop; -- If a body exists then process for possible call connections. DECREMENT_INDENTATION; if TREE(NODE).BODY_PTR /= NULL_POINTER then EMIT_BODIES (TREE(NODE).BODY_PTR); end if; -- Write the 'end' of the package body. WRITE ("end " & EXTRACT(TREE(NODE).NAME) & " ;" ); if TREE(NODE).NODE_TYPE = TYPE_VIRTUAL_PACKAGE then WRITE (" --" & UNTRANS & " VIRTUAL PACKAGE"); end if; NEW_LINE ; end if; when TYPE_PROCEDURE => -- Skip this node if it is a Generic Instantiation. if TREE(NODE).GENERIC_STATUS = GENERIC_INSTANTIATION then return; end if; -- Write the subprogram declaration. NEW_LINE ; WRITE_WITHS_OF_VISIBLE_UNITS ( NODE ) ; WRITE ("procedure " & EXTRACT(TREE(NODE).NAME)); -- If the procedure has calling parameters then write them. if TREE(NODE).HAS_PARAMETERS then WRITE (" (HAS_PARAMETERS: TBD_TYPE)"); end if; WRITE_LINE (" is " ); -- Begin writing the declarative section. INCREMENT_INDENTATION ; -- Write the prologue. WRITE_PROLOGUE ( TREE(NODE).PROLOGUE_PTR ) ; -- Scan the DATA_CONNECT_LIST and write the 'use's. PTR := TREE(NODE).DATA_CONNECT_LIST ; while PTR /= NULL_POINTER loop WRITE_LINE ("use " & EXTRACT(TREE(TREE(LIST(PTR).ITEM).CONNECTEE).NAME) & " ;") ; PTR := LIST(PTR).NEXT ; end loop ; -- Scan the CONTAINED_ENTITY_LIST and write the nested components. PTR := TREE(NODE).CONTAINED_ENTITY_LIST; while PTR /= NULL_POINTER loop if TREE(LIST(PTR).ITEM).NODE_TYPE = TYPE_TASK or TREE(LIST(PTR).ITEM).NODE_TYPE in TYPE_VIRTUAL_PACKAGE..TYPE_PACKAGE then EMIT_SPECS (LIST(PTR).ITEM) ; end if ; EMIT_BODIES (LIST(PTR).ITEM); PTR := LIST(PTR).NEXT; end loop; -- End the declarative section. DECREMENT_INDENTATION ; -- If a body exists then process for possible call connections. if TREE(NODE).BODY_PTR /= NULL_POINTER then EMIT_BODIES (TREE(NODE).BODY_PTR); else -- Write the 'begin' followed by a null statement to permit -- compilation. WRITE_LINE ("begin"); INCREMENT_INDENTATION ; WRITE_LINE ("null ;") ; DECREMENT_INDENTATION ; end if; -- Write the 'end' statement. WRITE_LINE ("end " & EXTRACT(TREE(NODE).NAME) & " ;" ); when TYPE_FUNCTION => -- Skip if this node is a Generic Instantiation. if TREE(NODE).GENERIC_STATUS = GENERIC_INSTANTIATION then return; end if; -- Write the function declaration. NEW_LINE ; WRITE_WITHS_OF_VISIBLE_UNITS ( NODE ) ; WRITE ("function " & EXTRACT(TREE(NODE).NAME)); -- If the procedure has calling parameters then write them. if TREE(NODE).HAS_PARAMETERS then WRITE (" (HAS_PARAMETERS: TBD_TYPE)"); end if; -- Write the return portion of the declaration. WRITE_LINE (" return TBD_TYPE is ") ; -- Begin writing the declarative section. INCREMENT_INDENTATION ; -- Write the prologue. WRITE_PROLOGUE ( TREE(NODE).PROLOGUE_PTR ) ; -- Scan the DATA_CONNECT_LIST and write the 'use's. PTR := TREE(NODE).DATA_CONNECT_LIST ; while PTR /= NULL_POINTER loop WRITE_LINE ("use " & EXTRACT(TREE(TREE(LIST(PTR).ITEM).CONNECTEE).NAME) & " ;") ; PTR := LIST(PTR).NEXT ; end loop ; -- Scan the CONTAINED_ENTITY_LIST and write any nested components. PTR := TREE(NODE).CONTAINED_ENTITY_LIST; while PTR /= NULL_POINTER loop if TREE(LIST(PTR).ITEM).NODE_TYPE = TYPE_TASK or TREE(LIST(PTR).ITEM).NODE_TYPE in TYPE_VIRTUAL_PACKAGE..TYPE_PACKAGE then EMIT_SPECS (LIST(PTR).ITEM) ; end if ; EMIT_BODIES (LIST(PTR).ITEM); PTR := LIST(PTR).NEXT; end loop; -- End the declarative section. DECREMENT_INDENTATION ; -- If a body exists then process for possible call connections. if TREE(NODE).BODY_PTR /= NULL_POINTER then EMIT_BODIES (TREE(NODE).BODY_PTR); else -- Write the 'begin' statement. WRITE_LINE ("begin"); end if; -- Write the return statement to permit compilation. INCREMENT_INDENTATION ; WRITE_LINE ("return TBD_OBJECT ;") ; DECREMENT_INDENTATION ; -- Write the 'end' statement. WRITE_LINE ("end " & EXTRACT(TREE(NODE).NAME) & " ;" ); when TYPE_TASK => NEW_LINE ; -- Write the task declarative statement. WRITE_LINE ("task body " & EXTRACT(TREE(NODE).NAME) & " is"); -- Begin writing the declarative section. INCREMENT_INDENTATION ; -- Write the prologue. WRITE_PROLOGUE ( TREE(NODE).PROLOGUE_PTR ) ; -- Scan the DATA_CONNECT_LIST and write the 'use's. PTR := TREE(NODE).DATA_CONNECT_LIST ; while PTR /= NULL_POINTER loop WRITE_LINE ("use " & EXTRACT(TREE(TREE(LIST(PTR).ITEM).CONNECTEE).NAME) & " ;") ; PTR := LIST(PTR).NEXT ; end loop ; -- Scan the CONTAINED_ENTITY_LIST and write any nested components. PTR := TREE(NODE).CONTAINED_ENTITY_LIST; while PTR /= NULL_POINTER loop EMIT_BODIES (LIST(PTR).ITEM); PTR := LIST(PTR).NEXT; end loop; DECREMENT_INDENTATION ; -- If a body exists then process for possible call connections. if TREE(NODE).BODY_PTR /= NULL_POINTER then EMIT_BODIES (TREE(NODE).BODY_PTR); else -- Write the 'begin' statement. WRITE_LINE ("begin"); end if; -- Start writing the executable portion of the task body. INCREMENT_INDENTATION; -- Scan the ENTRY_LIST for the entry points and write -- the corresponding accept statements. FIRST := TRUE; PTR := TREE(NODE).ENTRY_LIST; if PTR /= NULL_POINTER then -- Write a select structure if one or more entry points exists. while PTR /= NULL_POINTER and then LIST(PTR).ITEM /= NULL_POINTER loop if FIRST then FIRST := FALSE; WRITE_LINE ("select"); INCREMENT_INDENTATION; else DECREMENT_INDENTATION; WRITE_LINE ("or"); INCREMENT_INDENTATION; end if; TREE_PTR := LIST(PTR).ITEM; -- Write a guard condition if the entry point is guarded. if TREE(TREE_PTR).IS_GUARDED then WRITE_LINE ("when TBD_CONDITION =>"); end if; WRITE ("accept " & EXTRACT(TREE(TREE_PTR).NAME)); -- Write calling parameters if the entry point has them. if TREE(TREE_PTR).WITH_PARAMETERS then WRITE (" (HAS_PARAMETERS: TBD_TYPE)"); end if; WRITE_LINE (" ;"); PTR := LIST(PTR).NEXT; end loop; DECREMENT_INDENTATION; WRITE_LINE ("end select ;"); else -- Write a null statement to permit compilation. WRITE_LINE ("null ;") ; end if; -- Write the 'end' of the task declaration. DECREMENT_INDENTATION; WRITE_LINE ("end " & EXTRACT(TREE(NODE).NAME) & " ;"); when TYPE_BODY => -- Output the start of the body WRITE_LINE ("begin"); -- Write the code for calls by traversing CALLEE_LIST. INCREMENT_INDENTATION; PTR := TREE(NODE).CALLEE_LIST; if PTR = NULL_POINTER then -- If no calls exist, then write a null body. WRITE_LINE ("null ;") ; else while PTR /= NULL_POINTER loop TREE_PTR := LIST(PTR).ITEM ; -- If this call is for conditional or timed -- then write the first part of this call type. if TREE(TREE_PTR).CALL_VARIETY = GRAPHICS_DATA.CALL_CONNECTION_TYPE'(CONDITIONAL) then WRITE_LINE ("if TBD_CONDITION then") ; INCREMENT_INDENTATION ; elsif TREE(TREE_PTR).CALL_VARIETY = GRAPHICS_DATA.CALL_CONNECTION_TYPE'(TIMED) then WRITE_LINE ("select") ; INCREMENT_INDENTATION ; end if ; -- Callee List points to connections. CONN_PTR := TREE(TREE_PTR).CONNECTEE; -- If a connection is to an exported entity, check if it -- is connected to an inner level. begin if TREE( CONN_PTR ).NODE_TYPE in EXPORTED_PROCEDURE .. EXPORTED_ENTRY_POINT then while TREE( CONN_PTR ).CONNECTEE /= NULL_POINTER loop CONN_PTR := TREE( CONN_PTR ).CONNECTEE ; end loop ; end if ; exception when others => null ; end ; -- For function calls write a variable for the return value. if TREE(CONN_PTR).NODE_TYPE = TYPE_FUNCTION or TREE(CONN_PTR).NODE_TYPE = EXPORTED_FUNCTION or TREE(CONN_PTR).NODE_TYPE = IMPORTED_FUNCTION then WRITE ("TBD_OBJECT := ") ; end if ; -- Write the name of the subprogram called. WRITE (GET_FULL_NAME( CONN_PTR )) ; if TREE(CONN_PTR).NODE_TYPE in TYPE_PROCEDURE .. TYPE_FUNCTION then if TREE(CONN_PTR).HAS_PARAMETERS then WRITE (" (TBD_PARAMETERS)"); end if ; elsif TREE(CONN_PTR).NODE_TYPE = TYPE_ENTRY_POINT then if TREE(CONN_PTR).WITH_PARAMETERS then WRITE (" (TBD_PARAMETERS)"); end if ; end if ; WRITE_LINE (" ;"); -- If this call is conditional or timed then -- write the closing part. if TREE(TREE_PTR).CALL_VARIETY = GRAPHICS_DATA.CALL_CONNECTION_TYPE'(CONDITIONAL) then DECREMENT_INDENTATION ; WRITE_LINE ("end if ;") ; elsif TREE(TREE_PTR).CALL_VARIETY = GRAPHICS_DATA.CALL_CONNECTION_TYPE'(TIMED) then DECREMENT_INDENTATION ; WRITE_LINE ("or") ; WRITE_LINE (" delay TBD_TIME ;") ; WRITE_LINE ("end select ;") ; end if ; -- Process next call in the list. PTR := LIST(PTR).NEXT; end loop; end if ; DECREMENT_INDENTATION; when others => -- Should not occur here! Send an error message to the -- user an attempt to continue. NEW_LINE; WRITE_LINE ("*** Erroneous construct detected in Tree ***"); NEW_LINE; end case; NESTING_LEVEL := NESTING_LEVEL - 1 ; end EMIT_BODIES; ------------------------------------------------------------------------ -- The procedure to GENERATE_PDL ------------------------------------------------------------------------ procedure GENERATE_PDL ( PDL_FILE_NAME : in TREE_IO.FILENAME_TYPE ) is -- -- This procedure walks the current Graph Tree and emits the -- corresponding Ada PDL in the file designated by the user. -- The procedure expects that PDL_FILE_NAME contains the name -- of the file to place the generated PDL in. -- PTR : LIST_NODE_ACCESS_TYPE; TMP_FILE : TEXT_IO.FILE_TYPE; begin -- create the PDL output file with TEXT_IO calls declare use TEXT_IO ; begin TEXT_IO.CREATE ( PDL_FILE , OUT_FILE , TREE_IO.COMPLETE_FILE_NAME ( PDL_FILE_NAME , FILENAME_EXTENSION ) ) ; end ; -- If write to screen was requested then initialize the screen. if WRITE_PDL_TO_SCREEN then INITIALIZE_SCREEN_DISPLAY ; end if ; -- initialize the DECLARED array to show nothing yet declared for I in 1 .. MAX_TREE_NODES loop DECLARED(I) := FALSE; end loop; -- initialize the Indentation level and line length to -- permit multiple invocations of GENERATE_PDL INDENTATION := 0; LINE_LENGTH := 0; -- write the Support Package if that option was requested if INCLUDE_SUPPORT_PACKAGE then WRITE_SUPPORT_PACKAGE ; end if ; -- starting from the ROOT_NODE, generate the PDL for the -- specs of each contained entity PTR := TREE(ROOT_NODE).CONTAINED_ENTITY_LIST; TRACE (" start spec " & INTEGER'image(PTR) & " (list node) "); while PTR /= NULL_POINTER loop EMIT_SPECS (LIST(PTR).ITEM); PTR := LIST(PTR).NEXT; end loop; -- output blank line between the SPEC and BODY NEW_LINE ; -- starting from the ROOT_NODE, generate the PDL for the -- bodies of each contained entity PTR := TREE(ROOT_NODE).CONTAINED_ENTITY_LIST; TRACE (" start body " & INTEGER'image(PTR) & " (list node) "); while PTR /= NULL_POINTER loop EMIT_BODIES (LIST(PTR).ITEM); PTR := LIST(PTR).NEXT; end loop; -- close the PDL file TEXT_IO.CLOSE (PDL_FILE); -- If write to screen was requested then terminate the display. if WRITE_PDL_TO_SCREEN then TERMINATE_SCREEN_DISPLAY ; end if ; exception when others => if TEXT_IO.IS_OPEN (PDL_FILE) then -- write an error message indication unsuccessful completion WRITE_LINE (" PDL generation unsuccessfully completed "); -- close the PDL file TEXT_IO.CLOSE (PDL_FILE); else raise; end if; end GENERATE_PDL; end PDL_GEN; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --util_for_tree_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-01-03 15:40 by JL with SYSTEM ; with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; with GRAPHICS_DATA ; use GRAPHICS_DATA ; with MMI_PARAMETERS ; use MMI_PARAMETERS ; with TREE_DATA ; use TREE_DATA ; with TREE_IO ; use TREE_IO ; package UTIL_FOR_TREE is -- =========================================================== -- -- This package provides the common MMI functions that use -- tree data and operations. It was seperated from package -- "UTILITIES" on 27 Aug 1985. -- -- ========================================================== package GRAPHICS renames GRAPHICS_DATA ; procedure ARCHIVE_THE_TREE ; -- ===================================================================== -- This procedure saves the tree data to allow recovery -- ===================================================================== procedure RECOVER_THE_TREE ; -- ===================================================================== -- This procedure recover the tree data allowing for abort -- recovery/undo. Deletes the current display, recovers -- the archived tree data, then redraws the tree. -- ===================================================================== function CHECK_IF_GENERIC_INSTAN ( TREE_NODE : TREE_NODE_ACCESS_TYPE ) return BOOLEAN ; -- ===================================================================== -- This procedure returns true if the TREE_NODE passed to it is -- a generic instantiation. -- ===================================================================== function COMPUTE_NESTING_LEVEL (TREE_POINTER : in TREE_NODE_ACCESS_TYPE) return INTEGER ; -- =================================================== -- This function computes the nesting level of the -- object whose Tree pointer is passed to it. -- =================================================== procedure DISPLAY_AND_IDENTIFY ( ENTITY_ITEM : ENTITY_TYPE ; ENTITY_NAME : TREE_DATA.NAME_TYPE ; LABEL_POINT : GRAPHICS_DATA.POINT ; SIZE_POINT : in out GRAPHICS_DATA.POINT ; COLOR : GRAPHICS_DATA.COLOR_TYPE ; REFERENCE_SEG_ID : in out GKS_SPECIFICATION.SEGMENT_NAME ) ; -- ========================================================= -- This procedure displays the entity and returns the -- segment identifier. -- ========================================================= procedure DRAW_GRAPH_TREE ( PARENT : in TREE_NODE_ACCESS_TYPE := ROOT_NODE ; SET_GRAPH_VIEW : in Boolean := false ) ; -- ========================================================= -- This procedure draws the contents of the graph tree to -- the graphics display. -- ========================================================= function GET_FILE_HANDLE ( SUPRESS_CLEAR_SCREEN : in BOOLEAN := false ) return TREE_IO.FILENAME_TYPE ; -- =================================================== -- This function prompts the user for a filename and -- opens the file returning the FILE_TYPE needed to -- access the file. -- =================================================== function GET_FIGURE_TYPE ( PARENT : ENTITY_TYPE ) return GRAPHICS_DATA.GRAPHIC_ENTITY ; -- ========================================================= -- This procedure returns the figure_entity declaration -- for the corresponding entity_type declaration. -- ========================================================= function GET_GENERIC_LABEL_STRING ( TREE_ELEMENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ) return String ; -- =================================================== -- This function returns the proper generic label. -- =================================================== function GET_GENERIC_OFFSET_LOCATION ( GRAPH_ELEMENT : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ) return GRAPHICS_DATA.POINT ; -- =================================================== -- This function returns the proper generic label location. -- =================================================== function GET_LABEL_STRING ( TREE_ELEMENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ) return String ; -- =================================================== -- This function returns the proper basic label. -- =================================================== function GET_LINE_TYPE ( PARENT : ENTITY_TYPE ) return GRAPHICS_DATA.LINE_ENTITY ; -- ========================================================= -- This procedure returns the line_entity declaration -- for the corresponding entity_type declaration. -- ========================================================= function GET_OFFSET_LOCATION ( GRAPH_ELEMENT : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ) return GRAPHICS_DATA.POINT ; -- =================================================== -- This function returns the proper label location. -- =================================================== procedure LABEL_CALL_MARKING ( TREE_NODE : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) ; -- ========================================================= -- This procedure draws the marker symbol for a call -- connection that is timed or conditional. -- ========================================================= function LOWEST_COMMON_PARENT (FIRST_TREE_NODE, SECOND_TREE_NODE : in TREE_NODE_ACCESS_TYPE) return TREE_NODE_ACCESS_TYPE ; -- =================================================== -- This function determines the lowest common parent -- of the two given tree nodes. -- =================================================== procedure PERFORM_GRAPH_TREE_OP ( PARENT : in TREE_DATA.TREE_NODE_ACCESS_TYPE ; OPERATION : in SEGMENT_OPS_TYPE ) ; -- ========================================================= -- This procedure performs the selected operation on the -- subtree defined by PARENT. -- ========================================================= procedure PERFORM_LINE_OP ( TREE_POINTER : in TREE_DATA.TREE_NODE_ACCESS_TYPE ; OPERATION : in SEGMENT_OPS_TYPE ) ; -- ========================================================= -- This procedure performs the selected operation on the -- line defined by TREE_POINTER. -- ========================================================= procedure PERFORM_SEGMENT_OP ( SEGMENT: in GKS_SPECIFICATION.SEGMENT_NAME ; OPERATION : in SEGMENT_OPS_TYPE ) ; -- ========================================================= -- This procedure performs the selected operation on the -- specified segment. -- ========================================================= procedure PICK_GRAPH_ENTITY ( PROMPT : in STRING ; GRAPH_NODE : in out TREE_DATA.GRAPH_NODE_ACCESS_TYPE ) ; -- ========================================================= -- This procedure performs the prompt display and graph node -- lookup for a picked graphic entity. -- The routine exits with the window being -- the GRAPH_VIEW_PORT. -- ========================================================= procedure REQUEST_CONNECTION (LINE_PARENT : in TREE_DATA.TREE_NODE_ACCESS_TYPE ; START_POINT : in GRAPHICS_DATA.POINT ; END_POINT : in GRAPHICS_DATA.POINT ; CONNECTION : in out TREE_DATA.LINE_TYPE ) ; ----------------------------------------------------------------- -- This procedure performs the operations necessary to -- have the User enter the points which define a series -- of line segments which form a connection between the -- starting and ending points. ----------------------------------------------------------------- procedure REQUEST_LABEL ( LABEL : in out TREE_DATA.NAME_TYPE ; OK_IF_BLANK : in BOOLEAN := false ; OK_IF_OVERLOAD : in BOOLEAN := false ) ; -- ========================================================== -- Prompt the operator for the label of a graphical entity, -- and verify the validity of the label. -- ========================================================== procedure REQUEST_LABEL ( LABEL : in out TREE_DATA.NAME_TYPE ; PROMPT : in STRING ; OK_IF_BLANK : in BOOLEAN := false ; OK_IF_OVERLOAD : in BOOLEAN := false ) ; -- ========================================================== -- Prompt the operator for the label of a graphical entity, -- and verify the validity of the label. -- ========================================================== procedure REQUEST_POINT ( DISPLAY_STRING : in STRING ; REFERENCE_POINT : in out GRAPHICS_DATA.POINT ; PARENT : in out TREE_DATA.TREE_NODE_ACCESS_TYPE ; CURSOR_PLACEMENT : in Boolean := False ; LABEL_CREATE : in LABEL_CREATE_TYPE := NOT_LABEL ) ; -- ========================================================= -- This procedure displays the received string to the -- operator, and returns an operator specified point and -- the associated parent entity. -- ========================================================= procedure REQUEST_POINTS ( REFERENCE_POINT : in out GRAPHICS_DATA.POINT ; SIZE_POINT : in out GRAPHICS_DATA.POINT ; PARENT : in out TREE_DATA.TREE_NODE_ACCESS_TYPE ; ENCLOSED_ENTITIES : in out TREE_DATA.ENCLOSED_ENTITIES_TYPE ; ENCLOSURE_EXISTS : in out BOOLEAN ) ; -- ========================================================= -- This procedure request the operator to input the upper -- left and lower right points of the rectangle which -- delineates the area enclosing the entity to be drawn. -- ========================================================= procedure REQUEST_PROLOGUE ( PROLOGUE_NODE : in TREE_DATA.PROLOGUE_NODE_ACCESS_TYPE ) ; -- ========================================================== -- Prompt the operator for the PROLOGUE for a graphical entity. -- ========================================================== procedure DISPLAY_PROLOGUE ( PROLOGUE_NODE : in TREE_DATA.PROLOGUE_NODE_ACCESS_TYPE ) ; -- ========================================================== -- Display the PROLOGUE for a graphical entity. -- ========================================================== function SCOPE_CHECK ( NEW_ENTITY_POINT : in GRAPHICS_DATA.POINT ; PARENT : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) return BOOLEAN ; -- ========================================================== -- If the specified new entity being drawn is within the -- boundary of the Parent's reference and size points then -- return true; else return false. -- ========================================================== function SCOPE_SEARCH ( REFERENCE_POINT : in GRAPHICS_DATA.POINT ) return TREE_DATA.TREE_NODE_ACCESS_TYPE ; -- ========================================================== -- Return a Tree Pointer to the Parent of the user -- specified reference point. The Parent is the object -- whose reference and size points contain the user -- specified reference point. -- ========================================================== procedure VIEW_WINDOW_CHECK ( PARENT : in TREE_NODE_ACCESS_TYPE ) ; -- ======================================================== -- Assure that the entire subtree defined by the specified -- parent is visible on the view window. -- ======================================================== --------------------------------------------------------------- -- This exception is raised if an utility subprogram is unable -- to properly complete the requested operation. --------------------------------------------------------------- UTILITY_FAILED : exception ; end UTIL_FOR_TREE ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --util_for_tree_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-02-06 11:05 BY JB with GRAPHIC_DRIVER ; use GRAPHIC_DRIVER ; with VIRTUAL_TERMINAL_INTERFACE ; use VIRTUAL_TERMINAL_INTERFACE ; with TEXT_IO ; use TEXT_IO; with TREE_OPS ; with TRACE_PKG ; with UTILITIES ; use UTILITIES ; package body UTIL_FOR_TREE is -- =========================================================== -- -- This package provides the common MMI functions that use -- tree data and operations. It was seperated from package -- "UTILITIES" on 27 Aug 1985. -- -- ========================================================== procedure ARCHIVE_THE_TREE is -- save the tree by assigning all nodes -- to archive locations begin ARCHIVE_TREE := TREE ; ARCHIVE_GRAPH := GRAPH ; ARCHIVE_LIST := LIST ; ARCHIVE_PROLOGUE := PROLOGUE ; end ARCHIVE_THE_TREE ; procedure RECOVER_THE_TREE is -- initialize the tree by assigning all nodes -- to startup state begin -- delete the current tree PERFORM_GRAPH_TREE_OP ( ROOT_NODE, DELETED ) ; -- recover the tree data TREE := ARCHIVE_TREE ; GRAPH := ARCHIVE_GRAPH ; LIST := ARCHIVE_LIST ; PROLOGUE := ARCHIVE_PROLOGUE ; -- display the old tree DRAW_GRAPH_TREE ; end RECOVER_THE_TREE ; function COMPUTE_NESTING_LEVEL (TREE_POINTER : in TREE_NODE_ACCESS_TYPE) return INTEGER is -- =================================================== -- This function computes the nesting level of the -- object whose Tree pointer is passed to it. -- =================================================== NESTING_LEVEL : INTEGER := 0; PARENT : TREE_NODE_ACCESS_TYPE := NULL_POINTER ; begin if TREE_POINTER = ROOT_NODE then -- the node is the root, which is not nested at all return 0 ; else PARENT := TREE(TREE_POINTER).PARENT ; NESTING_LEVEL := 1 ; while PARENT /= ROOT_NODE loop PARENT := TREE(PARENT).PARENT ; NESTING_LEVEL := NESTING_LEVEL + 1 ; end loop ; return NESTING_LEVEL ; end if ; exception when others => DISPLAY_ERROR (" PROGRAM ERROR -- in nesting level computation ") ; TRACE_PKG.TRACE (" PROGRAM ERROR -- in nesting level computation ") ; return MAX_NESTING_LEVEL ; end COMPUTE_NESTING_LEVEL ; procedure DRAW_GRAPH_TREE ( PARENT : in TREE_NODE_ACCESS_TYPE := ROOT_NODE ; SET_GRAPH_VIEW : in Boolean := false ) is -- ========================================================= -- This procedure draws the contents of the graph tree -- in the graphics window. Each segment is drawn with -- the stored parameters in the graph_tree, any parameter -- not in the graph_tree or Ada_tree will use the -- system default parameter for that item. -- ========================================================= VISITED_NODES : array ( TREE_DATA.GRAPH'First..TREE_DATA.GRAPH'Last ) of Boolean := ( TREE_DATA.GRAPH'First..TREE_DATA.GRAPH'Last => False ) ; CURRENT_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; END_POINT : GRAPHICS_DATA.POINT ; GRAPH_ELEMENT : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; GRAPH_ENTITY : TREE_DATA.ENTITY_TYPE ; GRAPH_MASTER_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; GPTR : TREE_DATA.TREE_NODE_ACCESS_TYPE ; SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; START_POINT : GRAPHICS_DATA.POINT ; SIZE_LOCATION : GRAPHICS_DATA.POINT ; LINE_NODES : TREE_DATA.LINE_TYPE ; WALK_STATE : TREE_OPS.WALK_STATE_TYPE ; begin -- DRAW_GRAPH_TREE if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "UTIL_FOR_TREE.DRAW_GRAPH_TREE entered") ; end if ; -- set the window to graphics view port GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- check each element in the graph tree by walking the syntax tree TREE_OPS.START_TREE_WALK ( PARENT , WALK_STATE ) ; loop -- get the tree node to be processed TREE_OPS.TREE_WALK ( WALK_STATE, GRAPH_MASTER_NODE ) ; exit when GRAPH_MASTER_NODE = NULL_POINTER or GRAPH_MASTER_NODE = ROOT_NODE ; -- no more nodes to walk -- determine the associated graph_node GRAPH_ELEMENT := TREE( GRAPH_MASTER_NODE ).GRAPH_DATA ; -- verify that graph_node is valid and has not been drawn yet if GRAPH_ELEMENT = NULL_POINTER or else ( not VISITED_NODES( GRAPH_ELEMENT ) ) then -- determine the type of entity to draw GRAPH_ENTITY := TREE_DATA.TREE( GRAPH_MASTER_NODE ).NODE_TYPE ; -- now draw the proper graphical entity -- TRACE OF REDRAW if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE("UTIL_FOR_TREE.DRAW_GRAPH_TREE entity to draw =" & TREE_DATA.ENTITY_TYPE'Image ( GRAPH_ENTITY ) ) ; end if ; -- first draw the symbol if required case GRAPH_ENTITY is when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE | TYPE_PROCEDURE | TYPE_FUNCTION | TYPE_TASK | TYPE_BODY => -- load the body color if required if GRAPH_ENTITY = TYPE_BODY then GRAPHICS_DATA.ENTITY_COLOR( BODY_FIGURE ) := -- use the color of the parent GRAPHICS_DATA.ENTITY_COLOR( GET_FIGURE_TYPE ( TREE(TREE(GRAPH_MASTER_NODE).PARENT).NODE_TYPE )) ; end if ; -- draw the figure SEGMENT := GRAPHIC_DRIVER.DRAW_FIGURE ( GET_FIGURE_TYPE ( GRAPH_ENTITY ) , TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION , TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.SIZE ) ; TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.SEGMENT_ID := SEGMENT ; when others => -- no draw required null ; end case ; -- GRAPH_ENTITY first draw -- second draw a line segments symbol if required case GRAPH_ENTITY is when EXPORTED_PROCEDURE .. CONNECTION_FOR_DATA => -- draw figure LINE_NODES := TREE_DATA.TREE( GRAPH_MASTER_NODE ).LINE ; if LINE_NODES(1) /= NULL_POINTER then -- a line exists to be drawn -- show that the first node has been visited LABEL_CALL_MARKING( GRAPH_MASTER_NODE ) ; VISITED_NODES ( LINE_NODES(1) ) := True ; for I in 2 .. MAXIMUM_NO_LINE_SEGMENTS loop if LINE_NODES(I) = NULL_POINTER then -- line is completed exit ; else -- draw the line segment TREE_DATA.GRAPH( LINE_NODES(I-1) ).DATA.SEGMENT_ID := GRAPHIC_DRIVER.DRAW_LINE ( GET_LINE_TYPE ( GRAPH_ENTITY ) , TREE_DATA.GRAPH( LINE_NODES(I-1) ).DATA.LOCATION, TREE_DATA.GRAPH( LINE_NODES(I) ).DATA.LOCATION ); VISITED_NODES ( LINE_NODES(I) ) := True ; end if ; end loop ; end if ; when others => -- no draw required null ; end case ; -- GRAPH_ENTITY second draw -- third draw the label if required case GRAPH_ENTITY is when TYPE_BODY | CONNECTION_BY_CALL | CONNECTION_FOR_DATA => null ; -- nothing to label when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE | TYPE_PROCEDURE | TYPE_FUNCTION | TYPE_TASK => -- the label graph node may not be the first to be -- encountered, so use the TREEs GRAPH_NODE value. GPTR := TREE( GRAPH_MASTER_NODE ).GRAPH_DATA ; GRAPHIC_DRIVER.LABEL ( SEGMENT , SIZE_LOCATION , GET_OFFSET_LOCATION( GPTR ) , GET_LABEL_STRING( GRAPH_MASTER_NODE ) , GRAPHICS_DATA.ENTITY_COLOR( GET_FIGURE_TYPE ( GRAPH_ENTITY ) ) , GRAPHICS_DATA.WHITE ) ; TREE_DATA.GRAPH( GPTR ).DATA.LABEL_SEG_ID := SEGMENT ; VISITED_NODES( GPTR ) := True ; when others => -- import and export labels -- the label graph node may not be the first to be -- encountered, so use the TREEs GRAPH_NODE value. GPTR := TREE( GRAPH_MASTER_NODE ).GRAPH_DATA ; GRAPHIC_DRIVER.LABEL ( SEGMENT , SIZE_LOCATION , GET_OFFSET_LOCATION( GPTR ) , GET_LABEL_STRING ( GRAPH_MASTER_NODE ) , -- use the color of the parent GRAPHICS_DATA.ENTITY_COLOR( GET_FIGURE_TYPE ( TREE(TREE(GRAPH_MASTER_NODE).PARENT).NODE_TYPE ) ) , GRAPHICS_DATA.WHITE ) ; TREE_DATA.GRAPH( GPTR ).DATA.LABEL_SEG_ID := SEGMENT ; VISITED_NODES( GPTR ) := True ; end case ; -- GRAPH_ENTITY third draw -- forth draw the generic label if required case GRAPH_ENTITY is when TYPE_PACKAGE | TYPE_PROCEDURE | TYPE_FUNCTION => -- draw the generic status label if a generic case TREE_DATA.TREE( GRAPH_MASTER_NODE ).GENERIC_STATUS is when GENERIC_DECLARATION | GENERIC_INSTANTIATION => GRAPHIC_DRIVER.LABEL ( SEGMENT , SIZE_LOCATION , GET_GENERIC_OFFSET_LOCATION( GRAPH_ELEMENT ) , GET_GENERIC_LABEL_STRING ( GRAPH_MASTER_NODE ) , GRAPHICS_DATA.ENTITY_COLOR( GET_FIGURE_TYPE ( TREE(GRAPH_MASTER_NODE).NODE_TYPE ) ) , GRAPHICS_DATA.WHITE ) ; -- load the generic label segment id TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LABEL2_SEG_ID := SEGMENT ; when others => -- NON_GENERIC null ; end case ; when others => null ; -- no draw required end case ; -- GRAPH_ENTITY forth draw -- set the current node as having been visited if GRAPH_ELEMENT /= NULL_POINTER then VISITED_NODES ( GRAPH_ELEMENT ) := True ; end if ; end if ; end loop ; -- GRAPH_ELEMENT -- return the window to menu view port if SET_GRAPH_VIEW then GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE' ( GRAPH_VIEW_PORT ) ) ; else GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE' ( MENU_VIEW_PORT ) ) ; end if ; end DRAW_GRAPH_TREE ; function GET_OFFSET_LOCATION ( GRAPH_ELEMENT : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ) return GRAPHICS_DATA.POINT is -- The function returns the proper label to print OFFSET_LOCATION : GRAPHICS_DATA.POINT ; GRAPH_ENTITY : TREE_DATA.ENTITY_TYPE := TREE( GRAPH( GRAPH_ELEMENT ).OWNING_TREE_NODE ).NODE_TYPE ; begin -- GET_OFFSET_LOCATION case GRAPH_ENTITY is when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE => OFFSET_LOCATION.X := TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.X ; OFFSET_LOCATION.Y := TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.Y + GRAPHICS_DATA.ENTITY_NAME_Y_OFFSET ; when TYPE_TASK => OFFSET_LOCATION.X := TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.X -- add task offset + ( ( TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.Y - TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.SIZE.Y ) / 3 ); OFFSET_LOCATION.Y := TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.Y + GRAPHICS_DATA.ENTITY_NAME_Y_OFFSET ; when TYPE_PROCEDURE | TYPE_FUNCTION => OFFSET_LOCATION.X := TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.X ; OFFSET_LOCATION.Y := TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.Y - GRAPHICS_DATA.DEFAULT_CHARACTER_HEIGHT_SPACING ; when others => OFFSET_LOCATION := TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION ; end case ; -- GRAPH_ENTITY return OFFSET_LOCATION ; end GET_OFFSET_LOCATION ; function GET_LABEL_STRING ( TREE_ELEMENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ) return String is -- The function returns the proper label to print. GRAPH_ELEMENT : TREE_DATA.GRAPH_NODE_ACCESS_TYPE := TREE( TREE_ELEMENT ).GRAPH_DATA ; GRAPH_ENTITY : TREE_DATA.ENTITY_TYPE := TREE( TREE_ELEMENT ).NODE_TYPE ; function GET_GUARD_SYMBOL ( GUARDED : in Boolean ) return String is begin case GUARDED is when True => return GRAPHICS_DATA.GUARDED_ENTRY_SYMBOL ; when False => return "" ; end case ; -- GUARDED end GET_GUARD_SYMBOL ; begin -- GET_LABEL_STRING case GRAPH_ENTITY is when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE => return TRUNCATE_NAME ( TREE_DATA.TREE( TREE_ELEMENT ).NAME , -- text length calculation ( TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.SIZE.X - TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.X) ) ; when TYPE_TASK => return TRUNCATE_NAME ( TREE_DATA.TREE( TREE_ELEMENT ).NAME , -- text length calculation ( TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.SIZE.X - TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.X ) -- subtract task offset -(( TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.Y - TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.SIZE.Y )/3)); when TYPE_PROCEDURE => return TRUNCATE_NAME ( " " & TREE_DATA.TREE( TREE_ELEMENT ).NAME , -- text length calculation ( TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.SIZE.X - TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.X) , TREE_DATA.TREE( TREE_ELEMENT ).HAS_PARAMETERS ); when TYPE_FUNCTION => return TRUNCATE_NAME ( " " & GRAPHICS_DATA.FUNCTION_SYMBOL & TREE_DATA.TREE( TREE_ELEMENT ).NAME , -- text length calculation ( TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.SIZE.X - TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.X) , TREE_DATA.TREE( TREE_ELEMENT ).HAS_PARAMETERS ); when TYPE_ENTRY_POINT => return TRUNCATE_NAME ( GRAPHICS_DATA.TASK_ENTRY_DECL ( 1 ) & GET_GUARD_SYMBOL (TREE_DATA.TREE( TREE_ELEMENT ).IS_GUARDED) & TREE_DATA.TREE( TREE_ELEMENT ).NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH + GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET , TREE_DATA.TREE( TREE_ELEMENT ).WITH_PARAMETERS ) & GRAPHICS_DATA.TASK_ENTRY_DECL ( 2 ) ; when EXPORTED_ENTRY_POINT => return TRUNCATE_NAME ( GRAPHICS_DATA.TASK_ENTRY_DECL ( 1 ) & TREE_DATA.TREE( TREE_ELEMENT ).NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH + GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET ) & GRAPHICS_DATA.TASK_ENTRY_DECL ( 2 ) ; when IMPORTED_VIRTUAL_PACKAGE => return TRUNCATE_NAME ( GRAPHICS_DATA.VIRT_PKG_DECL ( 1 ) & TREE_DATA.TREE( TREE_ELEMENT ).NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH + GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET ) & GRAPHICS_DATA.VIRT_PKG_DECL ( 2 ) ; when IMPORTED_PACKAGE => return TRUNCATE_NAME ( GRAPHICS_DATA.PKG_DECL ( 1 ) & TREE_DATA.TREE( TREE_ELEMENT ).NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH + GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET ) & GRAPHICS_DATA.PKG_DECL ( 2 ) ; when IMPORTED_PROCEDURE | EXPORTED_PROCEDURE => return TRUNCATE_NAME ( GRAPHICS_DATA.SUBPROG_DECL ( 1 ) & TREE_DATA.TREE( TREE_ELEMENT ).NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH + GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET ) & GRAPHICS_DATA.SUBPROG_DECL ( 2 ) ; when IMPORTED_FUNCTION | EXPORTED_FUNCTION => return TRUNCATE_NAME ( GRAPHICS_DATA.SUBPROG_DECL ( 1 ) & GRAPHICS_DATA.FUNCTION_SYMBOL & TREE_DATA.TREE( TREE_ELEMENT ).NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH + GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET ) & GRAPHICS_DATA.SUBPROG_DECL ( 2 ) ; when EXPORTED_TYPE => return TRUNCATE_NAME ( GRAPHICS_DATA.TYPE_DECL ( 1 ) & TREE_DATA.TREE( TREE_ELEMENT ).NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH + GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET ) & GRAPHICS_DATA.TYPE_DECL ( 2 ) ; when EXPORTED_OBJECT => return TRUNCATE_NAME ( GRAPHICS_DATA.OBJECT_DECL ( 1 ) & TREE_DATA.TREE( TREE_ELEMENT ).NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH + GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET ) & GRAPHICS_DATA.OBJECT_DECL ( 2 ) ; when EXPORTED_EXCEPTION => return TRUNCATE_NAME ( GRAPHICS_DATA.EXCEPTION_DECL ( 1 ) & TREE_DATA.TREE( TREE_ELEMENT ).NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH + GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET ) & GRAPHICS_DATA.EXCEPTION_DECL ( 2 ) ; when others => return TRUNCATE_NAME ( TREE_DATA.TREE( TREE_ELEMENT ).NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH ) ; end case ; -- GRAPH_ENTITY end GET_LABEL_STRING ; function GET_GENERIC_OFFSET_LOCATION ( GRAPH_ELEMENT : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ) return GRAPHICS_DATA.POINT is -- The function returns the generic label location. GRAPH_ENTITY : TREE_DATA.ENTITY_TYPE := TREE( GRAPH( GRAPH_ELEMENT ).OWNING_TREE_NODE ).NODE_TYPE ; OFFSET_LOCATION : GRAPHICS_DATA.POINT ; begin -- GET_GENERIC_OFFSET_LOCATION case GRAPH_ENTITY is when TYPE_PROCEDURE | TYPE_FUNCTION => OFFSET_LOCATION.X := TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.X ; OFFSET_LOCATION.Y := TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.Y - GRAPHICS_DATA.STACKED_SIZE - GRAPHICS_DATA.DEFAULT_CHARACTER_HEIGHT_SPACING ; when others => -- TYPE_PACKAGE OFFSET_LOCATION.X := TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.X ; OFFSET_LOCATION.Y := TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.Y - GRAPHICS_DATA.DEFAULT_CHARACTER_HEIGHT_SPACING ; end case ; -- GRAPH_ENTITY return OFFSET_LOCATION ; end GET_GENERIC_OFFSET_LOCATION ; function GET_GENERIC_LABEL_STRING ( TREE_ELEMENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ) return String is -- The function returns the proper generic label to print. GRAPH_ELEMENT : TREE_DATA.GRAPH_NODE_ACCESS_TYPE := TREE( TREE_ELEMENT ).GRAPH_DATA ; begin -- GET_GENERIC_LABEL_STRING case TREE_DATA.TREE( TREE_ELEMENT ).GENERIC_STATUS is when GENERIC_DECLARATION => return TRUNCATE_NAME ( " " & GRAPHICS_DATA.GENERIC_DECL_SYMBOL & " ", TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.SIZE.X - TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.X ) ; when others => -- GENERIC_INSTANTIATION return TRUNCATE_NAME ( " " & GRAPHICS_DATA.GENERIC_INST_SYMBOL & " " & TREE_DATA.TREE( TREE_ELEMENT ).CU_INSTANTIATED , TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.SIZE.X - TREE_DATA.GRAPH( GRAPH_ELEMENT ).DATA.LOCATION.X ) ; end case ; end GET_GENERIC_LABEL_STRING ; function GET_FILE_HANDLE ( SUPRESS_CLEAR_SCREEN : in BOOLEAN := false ) return TREE_IO.FILENAME_TYPE is -- ==================================================== -- This function prompts the user for a filename and -- opens the file returning the FILE_TYPE needed to -- access the file. -- ==================================================== HANDLE : TREE_IO.FILENAME_TYPE := TREE_IO.DATA_FILENAME ; NEW_FILE_NAME : TREE_IO.FILENAME_TYPE ; BLANK_FILE_NAME : TREE_IO.FILENAME_TYPE := (others => ' ') ; LINE_1 : constant STRING := " Enter the file name to be used (omit extension)" ; ERROR_NOTICE : constant STRING := " ILLEGAL File Name Entered " ; PROMPT : constant STRING := "FILE NAME => " ; WORK_STRG : STRING( 1..TREE_IO.FILENAME_TYPE'Length+PROMPT'Length ) ; VALIDITY_CHECK : TEXT_IO.FILE_TYPE ; VALID_NAME : Boolean := False ; begin -- erase the crt screen if not SUPRESS_CLEAR_SCREEN then VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; end if ; -- repeat until a valid file name is received and checked loop -- present command to user VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( LINE_1 , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 )) ; WORK_STRG( 1..PROMPT'length ) := PROMPT ; for CNTR in INTEGER( PROMPT'Length+1 ) .. WORK_STRG'Length loop WORK_STRG( CNTR ) := ASCII.NUL ; end loop ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( WORK_STRG , CURSOR_ADDR'( WRITE_WITH_ADDRESS ) , ROW_NO( 24 ) , COL_NO( COLUMN_TYPE'first )) ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( NEW_FILE_NAME , CURSOR_ADDR'( READ_NO_ADDRESS ) , ROW_NO( 24 ) , COL_NO( COLUMN_TYPE'first )) ; -- return null file name if nothing is entered if NEW_FILE_NAME = BLANK_FILE_NAME then -- erase the crt screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; return TREE_IO.NULL_FILENAME ; end if ; CHECK_FOR_VALID_NAME : declare PERIOD : constant Character := '.' ; begin -- CHECK_FOR_VALID_NAME -- terminate name at a period for I in NEW_FILE_NAME'range loop if NEW_FILE_NAME( I ) = PERIOD then -- the rest of the name is garbage so fill with nulls for J in I..NEW_FILE_NAME'last loop NEW_FILE_NAME( J ) := ASCII.NUL ; end loop ; exit ; end if ; end loop ; TEXT_IO.CREATE ( VALIDITY_CHECK , TEXT_IO.OUT_FILE , TREE_IO.COMPLETE_FILE_NAME ( NEW_FILE_NAME , TREE_IO.TREE_EXTENSION ) ) ; -- destroy the file by deleting TEXT_IO.DELETE ( VALIDITY_CHECK ) ; -- set handle to file name HANDLE := NEW_FILE_NAME ; VALID_NAME := True ; exception -- CHECK_FOR_VALID_NAME -- invalid file name was input when NAME_ERROR | USE_ERROR => -- erase the crt screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; DISPLAY_ERROR( ERROR_NOTICE ) ; when others => -- error is unknown so pass it along raise ; end CHECK_FOR_VALID_NAME ; exit when VALID_NAME ; end loop ; -- erase the crt screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; return HANDLE ; end GET_FILE_HANDLE ; procedure LABEL_CALL_MARKING ( TREE_NODE : in TREE_NODE_ACCESS_TYPE ) is -- =================================================== -- This procedure draws a call connection symbol -- for a timed or conditional call or a data -- connection symbol. -- =================================================== LINE_NODES : TREE_DATA.LINE_TYPE := TREE_DATA.TREE( TREE_NODE ).LINE ; SIZE_LOCATION : GRAPHICS_DATA.POINT ; GRAPH_ENTITY : TREE_DATA.ENTITY_TYPE := TREE_DATA.TREE( TREE_NODE ).NODE_TYPE ; begin case GRAPH_ENTITY is when CONNECTION_BY_CALL => if TREE_DATA.TREE( TREE_NODE ).CALL_VARIETY = TIMED then GRAPHIC_DRIVER.LABEL ( TREE_DATA.GRAPH( LINE_NODES(1) ).DATA.LABEL_SEG_ID , SIZE_LOCATION , TREE_DATA.GRAPH( LINE_NODES(1) ).DATA.LOCATION , GRAPHICS_DATA.TIMED_CALL_SYMBOL , GRAPHICS_DATA.ENTITY_COLOR( GET_FIGURE_TYPE( GRAPH_ENTITY ) ) , GRAPHICS_DATA.WHITE ) ; elsif TREE_DATA.TREE( TREE_NODE ).CALL_VARIETY = CONDITIONAL then GRAPHIC_DRIVER.LABEL ( TREE_DATA.GRAPH( LINE_NODES(1) ).DATA.LABEL_SEG_ID , SIZE_LOCATION , TREE_DATA.GRAPH( LINE_NODES(1) ).DATA.LOCATION , GRAPHICS_DATA.CONDITIONAL_CALL_SYMBOL , GRAPHICS_DATA.ENTITY_COLOR( GET_FIGURE_TYPE( GRAPH_ENTITY ) ) , GRAPHICS_DATA.WHITE ) ; end if ; when CONNECTION_FOR_DATA => GRAPHIC_DRIVER.LABEL ( TREE_DATA.GRAPH( LINE_NODES(1) ).DATA.LABEL_SEG_ID , SIZE_LOCATION , TREE_DATA.GRAPH( LINE_NODES(1) ).DATA.LOCATION , GRAPHICS_DATA.DATA_ORIGIN_SYMBOL , GRAPHICS_DATA.ENTITY_COLOR( GET_FIGURE_TYPE( GRAPH_ENTITY ) ) , GRAPHICS_DATA.WHITE ) ; when others => null ; end case ; end LABEL_CALL_MARKING ; function LOWEST_COMMON_PARENT (FIRST_TREE_NODE, SECOND_TREE_NODE : in TREE_NODE_ACCESS_TYPE) return TREE_NODE_ACCESS_TYPE is -- =================================================== -- This function determines the lowest common parent of the -- two given tree nodes -- =================================================== FIRST_ANCESTOR_LIST : array (1 .. MAX_NESTING_LEVEL+2) of TREE_NODE_ACCESS_TYPE ; PARENT : TREE_NODE_ACCESS_TYPE := NULL_POINTER ; COUNT : integer := 1 ; begin if (FIRST_TREE_NODE = ROOT_NODE) or (SECOND_TREE_NODE = ROOT_NODE) then -- the node is the root return ROOT_NODE ; else PARENT := FIRST_TREE_NODE ; FIRST_ANCESTOR_LIST(COUNT) := PARENT ; -- store the ancestor list of first node while PARENT /= ROOT_NODE loop PARENT := TREE(PARENT).PARENT ; COUNT := COUNT + 1 ; FIRST_ANCESTOR_LIST(COUNT) := PARENT ; end loop ; PARENT := SECOND_TREE_NODE ; SECOND_PARENTS_LOOP: loop for SCAN in 1 .. COUNT loop exit SECOND_PARENTS_LOOP when PARENT = FIRST_ANCESTOR_LIST(SCAN) ; end loop ; PARENT := TREE(PARENT).PARENT ; end loop SECOND_PARENTS_LOOP ; return PARENT ; end if ; exception when others => DISPLAY_ERROR (" PROGRAM ERROR -- in lowest common parent") ; TRACE_PKG.TRACE (" PROGRAM ERROR -- in lowest common parent") ; return ROOT_NODE ; end LOWEST_COMMON_PARENT ; procedure REQUEST_CONNECTION (LINE_PARENT : in TREE_DATA.TREE_NODE_ACCESS_TYPE ; START_POINT : in GRAPHICS_DATA.POINT ; END_POINT : in GRAPHICS_DATA.POINT ; CONNECTION : in out TREE_DATA.LINE_TYPE ) is ----------------------------------------------------------------- -- This procedure performs the operations necessary to -- have the User enter the points which define a series -- of line segments which form a connection between the -- starting and ending points. ----------------------------------------------------------------- PLACE_CURSOR : constant Boolean := True ; GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; LAST_POINT : INTEGER := 1 ; LINE_POINT : GRAPHICS_DATA.POINT ; LOCAL_LINE : array (1..MAXIMUM_NO_LINE_SEGMENTS) of GRAPHICS_DATA.POINT ; LOCAL_SEGS : array (1..MAXIMUM_NO_LINE_SEGMENTS) of GKS_SPECIFICATION.SEGMENT_NAME ; PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; function FORCE_SQUARE_LINES ( LAST_POINT , NEXT_POINT : GRAPHICS_DATA.POINT ) return GRAPHICS_DATA.POINT is ----------------------------------------------------------- -- Based on the tangent of the angle off of horizontal and -- vertical, the forced line end point will be returned. ----------------------------------------------------------- -- tangent of minimum angle of divergence allowed from -- square. value entered is from angle in degrees. DIVERGENT_TANGENT : constant Float := 0.0875 ; -- 5 deg MAX_MAG , MIN_MAG : GRAPHICS_DATA.WC ; X_MAG : constant GRAPHICS_DATA.WC := abs( LAST_POINT.X - NEXT_POINT.X ) ; Y_MAG : constant GRAPHICS_DATA.WC := abs( LAST_POINT.Y - NEXT_POINT.Y ) ; begin -- FORCE_SQUARE_LINES if X_MAG = 0 or Y_MAG = 0 then return NEXT_POINT ; -- line is already square else if X_MAG > Y_MAG then -- find the largest change in x or y MAX_MAG := X_MAG ; MIN_MAG := Y_MAG ; -- x had the big one else MIN_MAG := X_MAG ; MAX_MAG := Y_MAG ; -- y had the big one end if ; if ( Float( MIN_MAG ) / Float( MAX_MAG ) ) < DIVERGENT_TANGENT then if X_MAG < Y_MAG then return ( LAST_POINT.X, NEXT_POINT.Y ) ; -- change y only else return ( NEXT_POINT.X, LAST_POINT.Y ) ; -- change x only end if ; else return NEXT_POINT ; -- angle is beyond square force limit end if ; end if ; end FORCE_SQUARE_LINES ; begin -- initialize the connection line CONNECTION := TREE_DATA.NULL_LINE ; -- start the line at the Start Point LOCAL_LINE(1) := START_POINT ; -- preset line point to first point in line LINE_POINT := START_POINT ; -- fill in the points until the point entered is close to -- the End Point for I in 2 .. (MAXIMUM_NO_LINE_SEGMENTS-1) loop -- turn on the abort operation ability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get the next point REQUEST_POINT(" enter connecting point number " & INTEGER'image(I-1) , LINE_POINT, PARENT, PLACE_CURSOR ) ; -- turn off the abort operation ability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check if this is the last point if (ABS(LINE_POINT.X - END_POINT.X) + ABS(LINE_POINT.Y - END_POINT.Y)) < GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET then exit ; end if; -- check for a forced square line LINE_POINT := FORCE_SQUARE_LINES( LOCAL_LINE( I-1 ), LINE_POINT ) ; -- draw the line segment defined by the current and previous point LOCAL_LINE (I) := LINE_POINT ; LOCAL_SEGS (I-1) := DRAW_LINE (GET_LINE_TYPE ( TREE(LINE_PARENT).NODE_TYPE ) , LOCAL_LINE(I-1), LOCAL_LINE(I) ); LAST_POINT := I ; end loop ; -- add the ending point to the list LAST_POINT := LAST_POINT + 1 ; LOCAL_LINE (LAST_POINT) := END_POINT ; -- draw the last line segment of the connection LOCAL_SEGS (LAST_POINT-1) := DRAW_LINE (GET_LINE_TYPE ( TREE(LINE_PARENT).NODE_TYPE ) , LOCAL_LINE(LAST_POINT-1), LOCAL_LINE(LAST_POINT) ); LOCAL_SEGS (LAST_POINT) := NULL_SEGMENT ; -- fill in the Connection with the data obtained for I in 1 .. LAST_POINT loop GRAPH_NODE := TREE_OPS.GET_NEW_GRAPH_NODE (LINE_PARENT) ; CONNECTION(I) := GRAPH_NODE ; GRAPH(GRAPH_NODE).DATA.LOCATION := LOCAL_LINE(I) ; GRAPH(GRAPH_NODE).DATA.SEGMENT_ID := LOCAL_SEGS(I) ; end loop ; exception when OPERATION_ABORTED_BY_OPERATOR => -- delete any segments allocated for I in 1 .. LAST_POINT-1 loop GRAPHIC_DRIVER.DELETE_SEGMENT( LOCAL_SEGS( I ) ) ; end loop ; -- turn off the abort operation ability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- pass exception to calling unit to finish handling raise ; when others => -- delete any segments allocated for I in 1 .. LAST_POINT-1 loop GRAPHIC_DRIVER.DELETE_SEGMENT( LOCAL_SEGS( I ) ) ; end loop ; -- turn off the abort operation ability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; DISPLAY_ERROR (" PROGRAM ERROR -- in connection drawing ") ; end REQUEST_CONNECTION ; procedure REQUEST_LABEL ( LABEL : in out TREE_DATA.NAME_TYPE ; OK_IF_BLANK : in BOOLEAN := false ; OK_IF_OVERLOAD : in BOOLEAN := false ) is -- ========================================================== -- Prompt the operator for the label of a graphical entity, -- and verify the validity of the label. -- ========================================================== begin if OK_IF_BLANK then REQUEST_LABEL ( LABEL, "Enter entity name, blank=no chng; " & "<RETURN>=done; <RubOut> or <DEL>" & "=delete;", OK_IF_BLANK, OK_IF_OVERLOAD ) ; else REQUEST_LABEL ( LABEL, "Enter entity name, 80 char. max; " & "<RETURN>=done; <RubOut> or <DEL>" & "=delete;", OK_IF_BLANK, OK_IF_OVERLOAD ) ; end if ; end REQUEST_LABEL ; procedure REQUEST_LABEL ( LABEL : in out TREE_DATA.NAME_TYPE ; PROMPT : in STRING ; OK_IF_BLANK : in BOOLEAN := false ; OK_IF_OVERLOAD : in BOOLEAN := false ) is -- ========================================================== -- Prompt the operator for the label of a graphical entity, -- and verify the validity of the label. -- ========================================================== LABEL_END : POSITIVE := 2 ; LETTER_OR_DIGIT : boolean := false ; UNDERLINE : boolean := false ; LAST_WAS_UNDERLINE : boolean := false ; VALID_LABEL : boolean := false ; FOUND : boolean ; END_OVERLOAD : NATURAL ; INVALID_LABEL : exception ; TEST_CHAR : CHARACTER ; LABEL_ERROR : constant STRING := " invalid string entered for Ada identifier " ; BLANK_LABEL : STRING (1..LABEL'length) := (others => ' ') ; subtype OVERLOAD_STRING is STRING(1..5) ; OVERLOAD_OPERATORS : constant array( 1..25 ) of OVERLOAD_STRING := ( 1 => """and""", 2 => """AND""", 3 => """or"" ", 4 => """OR"" ", 5 => """xor""", 6 => """XOR""", 7 => """="" ", 8 => """<"" ", 9 => """<="" ", 10 => """>"" ", 11 => """>="" ", 12 => """+"" ", 13 => """-"" ", 14 => """&"" ", 15 => """abs""", 16 => """ABS""", 17 => """not""", 18 => """NOT""", 19 => """*"" ", 20 => """/"" ", 21 => """mod""", 22 => """MOD""", 23 => """rem""", 24 => """REM""", 25 => """**"" " ) ; begin -- Loop until a valid label has been entered. while not VALID_LABEL loop begin -- Prompt the operator for the label. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( PROMPT , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- Retrieve the operator specified label and clear the -- prompt line. VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( LABEL, CURSOR_ADDRESS'(READ_WITH_ADDRESS), ROW_NO( 24 ), COL_NO( 1 )) ; VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- check for blank label if OK_IF_BLANK and then LABEL = BLANK_LABEL then exit ; end if ; -- check for overloaded operator if OK_IF_OVERLOAD and LABEL(1) = '"' then END_OVERLOAD := 1 ; for I in 3..5 loop if LABEL(I) = '"' then END_OVERLOAD := I ; exit ; end if ; end loop ; if END_OVERLOAD = 1 then raise INVALID_LABEL ; end if ; FOUND := false ; for I in OVERLOAD_OPERATORS'first .. OVERLOAD_OPERATORS'last loop if LABEL(1..END_OVERLOAD) = OVERLOAD_OPERATORS( I )(1..END_OVERLOAD) then FOUND := true ; exit ; end if ; end loop ; if not FOUND then raise INVALID_LABEL ; end if ; else if ( LABEL(1) not in 'A'..'Z' ) and ( LABEL(1) not in 'a'..'z' ) then raise INVALID_LABEL ; end if; for CHAR_INDEX in 2 .. LABEL'last loop TEST_CHAR := LABEL( CHAR_INDEX ) ; LETTER_OR_DIGIT := ( TEST_CHAR in 'A'..'Z' ) or ( TEST_CHAR in 'a'..'z' ) or ( TEST_CHAR in '0'..'9' ) ; UNDERLINE := ( TEST_CHAR = '_' ) ; LABEL_END := CHAR_INDEX ; if ( not LETTER_OR_DIGIT ) and ( not UNDERLINE ) then exit ; end if ; if UNDERLINE and LAST_WAS_UNDERLINE then raise INVALID_LABEL ; end if ; LAST_WAS_UNDERLINE := UNDERLINE ; end loop ; if LAST_WAS_UNDERLINE then raise INVALID_LABEL ; end if ; for CHAR_INDEX in LABEL_END .. LABEL'last loop if LABEL( CHAR_INDEX ) /= ' ' then raise INVALID_LABEL ; end if ; end loop ; end if ; VALID_LABEL := true ; -- If an invalid label was specified then display an error -- message to the operator. exception when INVALID_LABEL => DISPLAY_ERROR( LABEL_ERROR ) ; end ; end loop ; end REQUEST_LABEL ; procedure REQUEST_POINT ( DISPLAY_STRING : in STRING ; REFERENCE_POINT : in out GRAPHICS_DATA.POINT ; PARENT : in out TREE_DATA.TREE_NODE_ACCESS_TYPE ; CURSOR_PLACEMENT : in Boolean := False ; LABEL_CREATE : in LABEL_CREATE_TYPE := NOT_LABEL ) is -- ========================================================= -- This procedure displays the received string to the -- operator, and returns an operator specified point and -- the associated parent entity. -- ========================================================= UPPER_LEFT_CORNER : GRAPHICS_DATA.POINT ; LOWER_LEFT_CORNER : GRAPHICS_DATA.POINT ; UPPER_RIGHT_CORNER : GRAPHICS_DATA.POINT ; LOWER_RIGHT_CORNER : GRAPHICS_DATA.POINT ; PARENT_POINT_REF : GRAPHICS_DATA.POINT ; BLANK_LINE : constant String := " " ; PARENTS_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; PROPER_SCOPE : Boolean := False ; ROOT_INVALID_FOR_LABEL : exception ; begin while not PROPER_SCOPE loop -- set graphics window active. GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; -- Display the received string to the operator. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( DISPLAY_STRING , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- Place cursor at current reference point if CURSOR_PLACEMENT then GRAPHIC_DRIVER.PLACE_CURSOR( REFERENCE_POINT ) ; end if ; -- Retrieve the operator specified point. REFERENCE_POINT := GRAPHIC_DRIVER.GET_GRAPHICS_CURSOR_POSITION ; -- Clear the display line. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FCT'( CLEAR_A_LINE ) , ROW_NO( 23 ) ) ; -- Search tree for a scope reference. PARENT := SCOPE_SEARCH ( REFERENCE_POINT ) ; -- if it is not for a label, exit if LABEL_CREATE = NOT_LABEL then exit ; end if ; -- if it is for a label, check the overlap possiblity begin if PARENT = ROOT_NODE then raise ROOT_INVALID_FOR_LABEL ; end if ; if LABEL_CREATE = LABEL_IMPORT then PARENT_POINT_REF.X := GRAPH( TREE( PARENT ).GRAPH_DATA ).DATA.SIZE.X ; PARENT_POINT_REF.Y := REFERENCE_POINT.Y ; else -- export PARENT_POINT_REF.X := GRAPH( TREE( PARENT ).GRAPH_DATA ).DATA.LOCATION.X ; PARENT_POINT_REF.Y := REFERENCE_POINT.Y ; end if ; PARENTS_PARENT := TREE( PARENT ).PARENT ; UPPER_LEFT_CORNER.X := PARENT_POINT_REF.X - GRAPHICS_DATA.IMPORT_EXPORT_X_OFFSET ; UPPER_LEFT_CORNER.Y := PARENT_POINT_REF.Y ; LOWER_LEFT_CORNER.X := UPPER_LEFT_CORNER.X ; LOWER_LEFT_CORNER.Y := PARENT_POINT_REF.Y - GRAPHICS_DATA.DEFAULT_CHARACTER_HEIGHT ; UPPER_RIGHT_CORNER.X := UPPER_LEFT_CORNER.X + GRAPHICS_DATA.LABEL_MAX_LENGTH + ( 2 * GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET ) ; UPPER_RIGHT_CORNER.Y := UPPER_LEFT_CORNER.Y ; LOWER_RIGHT_CORNER.X := UPPER_RIGHT_CORNER.X ; LOWER_RIGHT_CORNER.Y := LOWER_LEFT_CORNER.Y ; if LABEL_CREATE = LABEL_IMPORT then -- for imports, the proper scoping exists if: -- 1) the reference points are within the Parent. -- 2) the size points are within the Parent's Parent. PROPER_SCOPE := ( PARENT = SCOPE_SEARCH ( UPPER_LEFT_CORNER )) and ( PARENT = SCOPE_SEARCH ( LOWER_LEFT_CORNER )) and ( PARENTS_PARENT = SCOPE_SEARCH ( UPPER_RIGHT_CORNER )) and ( PARENTS_PARENT = SCOPE_SEARCH ( LOWER_RIGHT_CORNER )) ; else -- for exports, the proper scoping exists if: -- 1) the reference points are within the Parent's Parent. -- 2) the size points are within the Parent. PROPER_SCOPE := ( PARENTS_PARENT = SCOPE_SEARCH ( UPPER_LEFT_CORNER )) and ( PARENTS_PARENT = SCOPE_SEARCH ( LOWER_LEFT_CORNER )) and ( PARENT = SCOPE_SEARCH ( UPPER_RIGHT_CORNER )) and ( PARENT = SCOPE_SEARCH ( LOWER_RIGHT_CORNER )) ; end if ; if not PROPER_SCOPE then -- tell the operator that the reference and -- and size points did not have proper scope DISPLAY_ERROR( "annotation will show improper scope," & " overlaps or overextends, re-try "); end if ; exception -- if root is chosen for label placement when ROOT_INVALID_FOR_LABEL => DISPLAY_ERROR (" invalid, an annotation cannot be placed at the outer scope") ; -- in case of constraint error for label position when others => DISPLAY_ERROR (" invalid, the annotation is too close to page boundaries ") ; end ; end loop ; end REQUEST_POINT ; function ENCLOSED_ENTITIES_HAVE_VALID_SCOPE ( ENCLOSED_ENTITIES : in TREE_DATA.ENCLOSED_ENTITIES_TYPE ) return BOOLEAN is -- ========================================================= -- This function verifies the nesting level of the -- contained entities and the out of scope entity which -- will be created. -- ========================================================= LIST_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; ENCLOSED_INDEX : INTEGER := ENCLOSED_ENTITIES'first ; NESTING_LEVEL : INTEGER := 0 ; procedure DETERMINE_ENCLOSED_NESTING_VALUE ( LIST_NODE : in TREE_DATA.LIST_NODE_ACCESS_TYPE ) is -- ========================================================= -- Locate the tree nodes with no contained entities, -- determine the nesting values of the located nodes, -- and find the node with the highest nesting value. -- ========================================================= CONTAINED_LIST : TREE_DATA.LIST_NODE_ACCESS_TYPE ; NESTING_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; NODE_LEVEL : INTEGER ; begin NESTING_NODE := TREE_DATA.LIST( LIST_NODE ).ITEM ; CONTAINED_LIST := TREE_DATA.TREE( NESTING_NODE ).CONTAINED_ENTITY_LIST ; -- If node has no contained entities then calculate the nesting level if CONTAINED_LIST = TREE_DATA.NULL_POINTER then NODE_LEVEL := COMPUTE_NESTING_LEVEL( NESTING_NODE ) ; if NODE_LEVEL > NESTING_LEVEL then NESTING_LEVEL := NODE_LEVEL ; end if ; -- If node has contained entities then find node with no -- contained entities. else while CONTAINED_LIST /= TREE_DATA.NULL_POINTER loop DETERMINE_ENCLOSED_NESTING_VALUE( CONTAINED_LIST ) ; CONTAINED_LIST := TREE_DATA.LIST( CONTAINED_LIST ).NEXT ; end loop ; end if ; end DETERMINE_ENCLOSED_NESTING_VALUE ; begin -- Verify the nesting level of each contained entity LIST_PTR := ENCLOSED_ENTITIES( ENCLOSED_INDEX ) ; while LIST_PTR /= TREE_DATA.NULL_POINTER loop -- Update the value of NESTING_LEVEL. DETERMINE_ENCLOSED_NESTING_VALUE( LIST_PTR ) ; ENCLOSED_INDEX := ENCLOSED_INDEX + 1 ; LIST_PTR := ENCLOSED_ENTITIES( ENCLOSED_INDEX ) ; end loop ; return NESTING_LEVEL < MAX_NESTING_LEVEL ; end ENCLOSED_ENTITIES_HAVE_VALID_SCOPE ; function VERIFY_ENCLOSED_ENTITIES ( ENCLOSED_ENTITIES : in TREE_DATA.ENCLOSED_ENTITIES_TYPE ; REFERENCE_POINT : in GRAPHICS_DATA.POINT ; SIZE_POINT : in GRAPHICS_DATA.POINT ; PARENT : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) return BOOLEAN is -- ========================================================= -- This function access the received array of list nodes, -- and verifies the enclosure validity of the entities -- represented in the list. -- ========================================================= LIST_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; SEARCH_LIST : TREE_DATA.LIST_NODE_ACCESS_TYPE ; SEARCH_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; CALLED_BY : TREE_DATA.LIST_NODE_ACCESS_TYPE ; CALLING_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; CALL_ITEM : TREE_DATA.LIST_NODE_ACCESS_TYPE ; ENCLOSED_INDEX_1 : INTEGER := ENCLOSED_ENTITIES'first ; TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; MEMBER_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; EXPORTED_PTR : TREE_DATA.MEMBERSHIP_LIST_TYPE ; BODY_LOCATION : GRAPHICS_DATA.POINT ; BODY_SIZE : GRAPHICS_DATA.POINT ; -- Error messages displayed to the operator BASIC_MESSAGE : constant STRING := " invalid, creation would invalidate " ; EXPORT_CONNECT_ERROR : constant STRING := "export connection " ; CALL_CONNECT_ERROR : constant STRING := "call connection " ; VISIBILITY_CONNECT_ERROR : constant STRING := "visibility connection " ; ENTRY_CONNECT_ERROR : constant STRING := "task entry connection " ; NESTING_ERROR : constant STRING := " invalid, entity placement would exceed maximum nesting level " ; CONTAINED_BODY_ERROR : constant STRING := " invalid, contained entity cannot be a body " ; INSTANTIATE_ERROR : constant STRING := " no entities can be placed inside an instantiated unit " ; IMPORT_ERROR : constant STRING := " invalid, contained entity may not have imports " ; INVALID_CONTAINMENT : exception ; function BODY_POINT_IN_ENTITY ( BODY_LOCATION : in GRAPHICS_DATA.POINT ; BODY_SIZE : in GRAPHICS_DATA.POINT ) return BOOLEAN is -- ========================================================= -- This function determines if the received points are -- within the rectangle defined by the reference and -- size points. If the points are within the rectangle -- the body is ( partially ) contained in the new entity. -- ========================================================= begin if BODY_LOCATION.Y > SIZE_POINT.Y and then BODY_SIZE.Y < REFERENCE_POINT.Y and then BODY_LOCATION.X < SIZE_POINT.X and then BODY_SIZE.X > REFERENCE_POINT.X then return true ; else return false ; end if ; end BODY_POINT_IN_ENTITY ; function CALL_IN_SAME_SCOPE ( CALLING_NODE : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) return BOOLEAN is -- ========================================================= -- This function access the list of enclosed entities -- received by the VERIFY_ENCLOSED_ENTITIES function, and -- and determines if the input node is also an enclosed -- entity. -- ========================================================= ALLOWED_CALL : BOOLEAN := false ; ENCLOSED_INDEX_2 : INTEGER := ENCLOSED_ENTITIES'first ; begin CALL_ITEM := ENCLOSED_ENTITIES( ENCLOSED_INDEX_2 ) ; while CALL_ITEM /= TREE_DATA.NULL_POINTER loop if CALLING_NODE = TREE_DATA.LIST( CALL_ITEM ).ITEM then ALLOWED_CALL := true ; exit ; end if ; ENCLOSED_INDEX_2 := ENCLOSED_INDEX_2 + 1 ; CALL_ITEM := ENCLOSED_ENTITIES( ENCLOSED_INDEX_2 ) ; end loop ; return ALLOWED_CALL ; end CALL_IN_SAME_SCOPE ; begin -- Verify that entity creation would not exceed maximum -- nesting level; if not ENCLOSED_ENTITIES_HAVE_VALID_SCOPE( ENCLOSED_ENTITIES ) then DISPLAY_ERROR ( NESTING_ERROR ) ; raise INVALID_CONTAINMENT ; end if ; -- If the parent of the entity to be created has a body then -- verify that the created entity does not overlap the body if TREE_DATA.TREE( PARENT ).NODE_TYPE in TREE_DATA.TYPE_VIRTUAL_PACKAGE .. TREE_DATA.TYPE_TASK then SEARCH_NODE := TREE_DATA.TREE( PARENT ).BODY_PTR ; if SEARCH_NODE /= TREE_DATA.NULL_POINTER then BODY_LOCATION := TREE_DATA.GRAPH( TREE_DATA.TREE( SEARCH_NODE ).GRAPH_DATA ).DATA.LOCATION ; BODY_SIZE := TREE_DATA.GRAPH( TREE_DATA.TREE( SEARCH_NODE ).GRAPH_DATA ).DATA.SIZE ; if BODY_POINT_IN_ENTITY( BODY_LOCATION, BODY_SIZE ) then DISPLAY_ERROR( CONTAINED_BODY_ERROR ) ; raise INVALID_CONTAINMENT ; end if ; end if ; if TREE_DATA.TREE( PARENT ).NODE_TYPE in TREE_DATA.TYPE_VIRTUAL_PACKAGE .. TREE_DATA.TYPE_FUNCTION and then TREE_DATA.TREE( PARENT ).GENERIC_STATUS = TREE_DATA.GENERIC_INSTANTIATION then DISPLAY_ERROR( INSTANTIATE_ERROR ) ; raise INVALID_CONTAINMENT ; end if ; end if ; -- Verify each entity in the received array of list nodes. LIST_PTR := ENCLOSED_ENTITIES( ENCLOSED_INDEX_1 ) ; while LIST_PTR /= TREE_DATA.NULL_POINTER loop -- If the contained entity has imports then display the error. TREE_NODE := TREE_DATA.LIST( LIST_PTR ).ITEM ; if TREE_DATA.TREE( TREE_NODE ).NODE_TYPE = TREE_DATA.TYPE_VIRTUAL_PACKAGE or TREE_DATA.TREE( TREE_NODE ).NODE_TYPE = TREE_DATA.TYPE_PACKAGE then if TREE_DATA.TREE( TREE_NODE ).IMPORTED_LIST /= TREE_DATA.NULL_POINTER then DISPLAY_ERROR( IMPORT_ERROR ) ; raise INVALID_CONTAINMENT ; end if ; -- If connections to the enclosed entities exist then -- display the error. EXPORTED_PTR := TREE_DATA.TREE( TREE_NODE ).EXPORTED_LIST ; while EXPORTED_PTR /= TREE_DATA.NULL_POINTER loop -- Locate the membership list of the exported item SEARCH_NODE := TREE_DATA.LIST( EXPORTED_PTR ).ITEM ; SEARCH_LIST := TREE_DATA.TREE( SEARCH_NODE ).MEMBERSHIP ; -- Verify each call to the exported entity. while SEARCH_LIST /= TREE_DATA.NULL_POINTER loop -- Retrieve the calling node. If the calling node is not -- the parent of the calling node then retrieve the parent -- of the body from which the call originates. MEMBER_NODE := TREE_DATA.LIST( SEARCH_LIST ).ITEM ; if MEMBER_NODE /= TREE_DATA.TREE( SEARCH_NODE ).PARENT then CALLED_BY := TREE_DATA.TREE( MEMBER_NODE ).MEMBERSHIP ; CALLING_NODE := TREE_DATA.LIST( CALLED_BY ).ITEM ; CALLING_NODE := TREE_DATA.TREE( CALLING_NODE ).PARENT ; if not CALL_IN_SAME_SCOPE( CALLING_NODE ) then DISPLAY_ERROR( BASIC_MESSAGE & EXPORT_CONNECT_ERROR ) ; raise INVALID_CONTAINMENT ; end if ; end if ; SEARCH_LIST := TREE_DATA.LIST( SEARCH_LIST ).NEXT ; end loop ; EXPORTED_PTR := TREE_DATA.LIST( EXPORTED_PTR ).NEXT ; end loop ; end if ; -- If the contained entity has a body then verify the calls -- performed by the body if TREE_DATA.TREE( TREE_NODE ).NODE_TYPE in TREE_DATA.TYPE_VIRTUAL_PACKAGE .. TREE_DATA.TYPE_TASK then -- Determine if the contained entity has a body SEARCH_NODE := TREE_DATA.TREE( TREE_NODE ).BODY_PTR ; if SEARCH_NODE /= TREE_DATA.NULL_POINTER then -- Verify that the calls performed by the body are within -- the scope of the enclosing entity SEARCH_LIST := TREE_DATA.TREE( SEARCH_NODE ).CALLEE_LIST ; while SEARCH_LIST /= TREE_DATA.NULL_POINTER loop CALLING_NODE := TREE_DATA.LIST( SEARCH_LIST ).ITEM ; CALLING_NODE := TREE_DATA.TREE( CALLING_NODE ).CONNECTEE ; if not CALL_IN_SAME_SCOPE( CALLING_NODE ) then DISPLAY_ERROR( BASIC_MESSAGE & CALL_CONNECT_ERROR ) ; raise INVALID_CONTAINMENT ; end if ; SEARCH_LIST := TREE_DATA.LIST( SEARCH_LIST ).NEXT ; end loop ; end if ; -- Verify that the contained data connections are within -- the scope of the enclosing entity SEARCH_LIST := TREE_DATA.TREE( TREE_NODE ).DATA_CONNECT_LIST ; while SEARCH_LIST /= TREE_DATA.NULL_POINTER loop CALLING_NODE := TREE_DATA.LIST( SEARCH_LIST ).ITEM ; CALLING_NODE := TREE_DATA.TREE( CALLING_NODE ).CONNECTEE ; if not CALL_IN_SAME_SCOPE( CALLING_NODE ) then DISPLAY_ERROR( BASIC_MESSAGE & VISIBILITY_CONNECT_ERROR ) ; raise INVALID_CONTAINMENT ; end if ; SEARCH_LIST := TREE_DATA.LIST( SEARCH_LIST ).NEXT ; end loop ; -- If the node is a task then verify that no export connections -- to the task entry points exist. if TREE_DATA.TREE(TREE_NODE).NODE_TYPE = TREE_DATA.TYPE_TASK then SEARCH_LIST := TREE_DATA.TREE( TREE_NODE ).ENTRY_LIST ; while SEARCH_LIST /= TREE_DATA.NULL_POINTER loop SEARCH_NODE := TREE_DATA.LIST( SEARCH_LIST ).ITEM ; CALLED_BY := TREE_DATA.TREE( SEARCH_NODE ).MEMBERSHIP ; while CALLED_BY /= TREE_DATA.NULL_POINTER loop MEMBER_NODE := TREE_DATA.LIST( CALLED_BY ).ITEM ; if MEMBER_NODE /= TREE_NODE then DISPLAY_ERROR( BASIC_MESSAGE & ENTRY_CONNECT_ERROR ) ; raise INVALID_CONTAINMENT ; end if ; CALLED_BY := TREE_DATA.LIST( CALLED_BY ).NEXT ; end loop ; SEARCH_LIST := TREE_DATA.LIST( SEARCH_LIST ).NEXT ; end loop ; end if ; end if ; -- Verify that the enclosed entity does not have export connections. SEARCH_LIST := TREE_DATA.TREE( TREE_NODE ).MEMBERSHIP ; while SEARCH_LIST /= TREE_DATA.NULL_POINTER loop MEMBER_NODE := TREE_DATA.LIST( SEARCH_LIST ).ITEM ; if TREE_DATA.TREE( MEMBER_NODE ).NODE_TYPE in TREE_DATA.EXPORTED_PROCEDURE .. TREE_DATA.EXPORTED_EXCEPTION then DISPLAY_ERROR( BASIC_MESSAGE & EXPORT_CONNECT_ERROR ) ; raise INVALID_CONTAINMENT ; elsif TREE_DATA.TREE( MEMBER_NODE ).NODE_TYPE in TREE_DATA.CONNECTION_BY_CALL .. TREE_DATA.CONNECTION_FOR_DATA then CALLING_NODE := TREE_DATA.TREE( MEMBER_NODE).PARENT ; -- If connection-by-call then determine parent of body if TREE_DATA.TREE( MEMBER_NODE ).NODE_TYPE = TREE_DATA.CONNECTION_BY_CALL then CALLING_NODE := TREE_DATA.TREE( CALLING_NODE ).PARENT ; end if ; if not CALL_IN_SAME_SCOPE( CALLING_NODE ) then DISPLAY_ERROR( BASIC_MESSAGE & VISIBILITY_CONNECT_ERROR ) ; raise INVALID_CONTAINMENT ; end if ; end if ; SEARCH_LIST := TREE_DATA.LIST( SEARCH_LIST ).NEXT ; end loop ; ENCLOSED_INDEX_1 := ENCLOSED_INDEX_1 + 1 ; LIST_PTR := ENCLOSED_ENTITIES( ENCLOSED_INDEX_1 ) ; end loop ; return true ; exception when INVALID_CONTAINMENT => return false ; end VERIFY_ENCLOSED_ENTITIES ; procedure REQUEST_POINTS ( REFERENCE_POINT : in out GRAPHICS_DATA.POINT ; SIZE_POINT : in out GRAPHICS_DATA.POINT ; PARENT : in out TREE_DATA.TREE_NODE_ACCESS_TYPE ; ENCLOSED_ENTITIES : in out TREE_DATA.ENCLOSED_ENTITIES_TYPE ; ENCLOSURE_EXISTS : in out BOOLEAN ) is -- ========================================================= -- This procedure request the operator to input the upper -- left and lower right points of the rectangle which -- delineates the area enclosing the entity to be drawn. -- ========================================================= BLANK_LINE : constant String := " " ; PROPER_SCOPE : Boolean := False ; UPPER_LEFT_PROMPT : constant String := "Place cursor at upper left" & " location of entity, " & "then press input device button"; LOWER_RIGHT_PROMPT : constant String := "Place cursor at lower right" & " location of entity, " & "then press input device button"; LIST_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; UPPER_RIGHT_CORNER : GRAPHICS_DATA.POINT ; LOWER_LEFT_CORNER : GRAPHICS_DATA.POINT ; OBJECT_LOC : GRAPHICS_DATA.POINT ; OBJECT_SIZE : GRAPHICS_DATA.POINT ; ENCLOSED_INDEX : INTEGER ; type OVERLAP_TYPE is ( OVER_CONTAINED_ENTITY , OVER_EXPORT , OVER_IMPORT , OVER_CONTAINED_EXPORT , OVER_CONTAINED_IMPORT ) ; function OVERLAPS_CHECK ( OVERLAP_TEST : OVERLAP_TYPE ; LIST_HEAD_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ) return boolean is -- ========================================================= -- This function return true if the selected placement -- points will overlap any item on the list specified -- by the input parameter, which must be the list head. -- ========================================================= SUB_LIST_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE := LIST_HEAD_PTR ; function TOTALLY_CONTAINED return boolean is -- ========================================================= -- This function return true if current placement points -- determine that the entity in question is totally -- enclosed; else return false -- ========================================================= begin if OBJECT_LOC.Y < REFERENCE_POINT.Y and then OBJECT_SIZE.Y > SIZE_POINT.Y and then OBJECT_LOC.X > REFERENCE_POINT.X and then OBJECT_SIZE.X < SIZE_POINT.X then return TRUE ; else return FALSE ; end if ; end TOTALLY_CONTAINED ; begin if OVERLAP_TEST = OVER_CONTAINED_ENTITY then -- check the body before checking the list if TREE( PARENT ).NODE_TYPE in TYPE_VIRTUAL_PACKAGE .. TYPE_TASK and then TREE( PARENT ).BODY_PTR /= NULL_POINTER then OBJECT_LOC := GRAPH( TREE( TREE( PARENT ).BODY_PTR ).GRAPH_DATA ).DATA.LOCATION ; OBJECT_SIZE := GRAPH( TREE( TREE( PARENT ).BODY_PTR ).GRAPH_DATA ).DATA.SIZE ; if OBJECT_LOC.Y > SIZE_POINT.Y and then OBJECT_SIZE.Y < REFERENCE_POINT.Y and then OBJECT_LOC.X < SIZE_POINT.X and then OBJECT_SIZE.X > REFERENCE_POINT.X then -- an overlap has been found return TRUE ; end if ; end if ; end if ; while SUB_LIST_PTR /= NULL_POINTER loop OBJECT_LOC := GRAPH( TREE( LIST(SUB_LIST_PTR).ITEM ).GRAPH_DATA ).DATA.LOCATION ; OBJECT_SIZE := GRAPH( TREE( LIST(SUB_LIST_PTR).ITEM ).GRAPH_DATA ).DATA.SIZE ; case OVERLAP_TEST is when OVER_CONTAINED_ENTITY => if OBJECT_LOC.Y > SIZE_POINT.Y and then OBJECT_SIZE.Y < REFERENCE_POINT.Y and then OBJECT_LOC.X < SIZE_POINT.X and then OBJECT_SIZE.X > REFERENCE_POINT.X then -- at least on overlap has been found, -- check if completely enclosed if TOTALLY_CONTAINED then -- a completely enclosed entity has been found, this knowledge -- is used to permit the creation of entities which contain -- existing entities ENCLOSED_ENTITIES ( ENCLOSED_INDEX ) := SUB_LIST_PTR ; ENCLOSED_INDEX := ENCLOSED_INDEX + 1 ; ENCLOSURE_EXISTS := TRUE ; else return TRUE ; end if ; end if ; if TREE( LIST( SUB_LIST_PTR ).ITEM ).NODE_TYPE in TYPE_VIRTUAL_PACKAGE .. TYPE_PACKAGE then -- check the contained export and import lists for overlap if OVERLAPS_CHECK( OVER_CONTAINED_EXPORT, TREE_OPS.GET_LIST_HEAD (LIST( SUB_LIST_PTR ).ITEM , EXPORTED_LIST) ) or else OVERLAPS_CHECK( OVER_CONTAINED_IMPORT, TREE_OPS.GET_LIST_HEAD (LIST( SUB_LIST_PTR ).ITEM , IMPORTED_LIST) ) then return TRUE ; end if ; elsif TREE( LIST( SUB_LIST_PTR ).ITEM ).NODE_TYPE = TYPE_TASK then -- check the entry list for overlap if OVERLAPS_CHECK( OVER_CONTAINED_EXPORT, TREE_OPS.GET_LIST_HEAD (LIST( SUB_LIST_PTR ).ITEM , ENTRY_LIST) ) then return TRUE ; end if ; end if ; when OVER_EXPORT | OVER_CONTAINED_IMPORT => if OBJECT_LOC.Y < REFERENCE_POINT.Y and then OBJECT_SIZE.Y > SIZE_POINT.Y and then OBJECT_LOC.X < SIZE_POINT.X and then OBJECT_SIZE.X > REFERENCE_POINT.X then -- an overlap has been found if not TOTALLY_CONTAINED then return TRUE ; end if ; end if ; when OVER_IMPORT | OVER_CONTAINED_EXPORT => if OBJECT_LOC.Y < REFERENCE_POINT.Y and then OBJECT_SIZE.Y > SIZE_POINT.Y and then OBJECT_SIZE.X > REFERENCE_POINT.X and then OBJECT_LOC.X < SIZE_POINT.X then -- an overlap has been found if not TOTALLY_CONTAINED then return TRUE ; end if ; end if ; end case ; SUB_LIST_PTR := LIST(SUB_LIST_PTR).NEXT ; end loop ; -- no overlap was found or a completely enclosed entity was found return FALSE ; end OVERLAPS_CHECK ; begin -- set graphics window active. GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; -- get box points in proper scope while not PROPER_SCOPE loop -- initialize list of enclosed entities for out-of-scope create ENCLOSED_ENTITIES := ( others => TREE_DATA.NULL_POINTER ) ; ENCLOSED_INDEX := ENCLOSED_ENTITIES'first ; -- set boolean to show no enclosed entities ENCLOSURE_EXISTS := false ; -- prompt operator to select upper left point. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( UPPER_LEFT_PROMPT , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- get the upper left box point. REFERENCE_POINT := GRAPHIC_DRIVER.GET_GRAPHICS_CURSOR_POSITION ; -- clear the user prompt. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FCT'( CLEAR_A_LINE ) , ROW_NO( 23 ) ) ; -- turn on point marker at upper left corner UTILITIES.REFERENCE_MARKER ( GKS_SPECIFICATION.VISIBLE , REFERENCE_POINT ) ; -- search tree for a scope reference and size point pair PARENT := SCOPE_SEARCH ( REFERENCE_POINT ) ; -- prompt operator to select lower right point VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( LOWER_RIGHT_PROMPT , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- get the lower right box point. SIZE_POINT := GRAPHIC_DRIVER.GET_GRAPHICS_CURSOR_POSITION ; -- clear the user prompt. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FCT'( CLEAR_A_LINE ) , ROW_NO( 23 ) ) ; -- turn off point marker at upper left corner UTILITIES.REFERENCE_MARKER ( GKS_SPECIFICATION.INVISIBLE , REFERENCE_POINT ) ; -- the proper scoping exists if: -- 1) the reference and size points are in valid -- relative locations. -- 2) the reference and size points have the same Parent. -- 3) the other corners also have the same Parent. UPPER_RIGHT_CORNER.X := SIZE_POINT.X ; UPPER_RIGHT_CORNER.Y := REFERENCE_POINT.Y ; LOWER_LEFT_CORNER.X := REFERENCE_POINT.X ; LOWER_LEFT_CORNER.Y := SIZE_POINT.Y ; PROPER_SCOPE := ( REFERENCE_POINT.X < SIZE_POINT.X ) and ( REFERENCE_POINT.Y > SIZE_POINT.Y ) and ( PARENT = SCOPE_SEARCH ( SIZE_POINT )) and ( PARENT = SCOPE_SEARCH ( UPPER_RIGHT_CORNER )) and ( PARENT = SCOPE_SEARCH ( LOWER_LEFT_CORNER )) ; if not PROPER_SCOPE then -- tell the operator that the reference and -- and size points did not have proper scope DISPLAY_ERROR( "invalid, entity points and corners " & "must be within the same scope" ); elsif COMPUTE_NESTING_LEVEL (PARENT) >= MAX_NESTING_LEVEL then -- check if the box would exceed the maximum nesting level DISPLAY_ERROR ( "invalid, entity placement would exceed maximum nesting level" ) ; PROPER_SCOPE := false ; elsif TREE( PARENT ).NODE_TYPE in ROOT .. TYPE_TASK then -- check that no entities would be graphically contained or -- partially overlapped within the box defined by the -- REFERENCE_POINT and SIZE_POINT. LIST_PTR := TREE_OPS.GET_LIST_HEAD (PARENT, CONTAINED_LIST) ; if OVERLAPS_CHECK( OVER_CONTAINED_ENTITY, LIST_PTR ) then PROPER_SCOPE := FALSE ; DISPLAY_ERROR (" invalid, entities may not overlap previously created entities " ) ; elsif TREE( PARENT ).NODE_TYPE in TYPE_VIRTUAL_PACKAGE .. TYPE_PACKAGE then if OVERLAPS_CHECK( OVER_EXPORT, TREE_OPS.GET_LIST_HEAD (PARENT , EXPORTED_LIST) ) or else OVERLAPS_CHECK( OVER_IMPORT, TREE_OPS.GET_LIST_HEAD (PARENT , IMPORTED_LIST) ) then PROPER_SCOPE := FALSE ; DISPLAY_ERROR (" invalid, entities may not overlap previously created annotations " ) ; end if; elsif TREE( PARENT ).NODE_TYPE = TYPE_TASK then -- check the entry list for overlap if OVERLAPS_CHECK( OVER_CONTAINED_EXPORT, TREE_OPS.GET_LIST_HEAD (PARENT , ENTRY_LIST) ) then PROPER_SCOPE := FALSE ; DISPLAY_ERROR (" invalid, entities may not overlap previously created annotations " ) ; end if ; end if; -- If enclosed entities exist then verify the enclosed entities. if PROPER_SCOPE and then ENCLOSURE_EXISTS then PROPER_SCOPE := VERIFY_ENCLOSED_ENTITIES ( ENCLOSED_ENTITIES, REFERENCE_POINT, SIZE_POINT, PARENT ) ; end if ; end if; end loop ; end REQUEST_POINTS ; procedure REQUEST_PROLOGUE ( PROLOGUE_NODE : in TREE_DATA.PROLOGUE_NODE_ACCESS_TYPE ) is -- ========================================================= -- This procedure request the operator to input the PROLOGUE -- ========================================================= BLANK_PROLOGUE_LINE : PROLOGUE_LINE := (others => ' ') ; DATA_LINE : PROLOGUE_LINE ; LAST_LINE : NATURAL := 22 ; begin -- clear the screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; for I in 1 .. PROLOGUE_COUNT loop -- display the previously entered lines, preceded by -- a blank line VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( BLANK_PROLOGUE_LINE , CURSOR_ADDRESS'(WRITE_WITH_ADDRESS), ROW_NO( LAST_LINE - I ), COL_NO( 1 ) ) ; for J in 1 .. I-1 loop VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( PROLOGUE(PROLOGUE_NODE).DATA(J) , CURSOR_ADDRESS'(WRITE_WITH_ADDRESS), ROW_NO( (LAST_LINE - I) + J ), COL_NO( 1 ) ) ; end loop ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( BLANK_PROLOGUE_LINE , CURSOR_ADDRESS'(WRITE_WITH_ADDRESS), ROW_NO( LAST_LINE ), COL_NO( 1 ) ) ; -- Prompt the operator for the line. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "Enter PROLOGUE text line " & INTEGER'image(I) & ", blank or (cr) = exit prologue ", FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- Retrieve the operator specified line DATA_LINE := BLANK_PROLOGUE_LINE ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( DATA_LINE , CURSOR_ADDRESS'(WRITE_WITH_ADDRESS), ROW_NO( 24 ) , COL_NO( 1 ) ) ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( DATA_LINE , CURSOR_ADDRESS'(READ_WITH_ADDRESS), ROW_NO( 24 ) , COL_NO( 1 ) ) ; PROLOGUE(PROLOGUE_NODE).DATA(I) := DATA_LINE ; VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; exit when DATA_LINE = BLANK_PROLOGUE_LINE ; end loop ; exception when others => -- continue with the old parent DISPLAY_ERROR("PROGRAM ERROR -- in request PROLOGUE") ; raise ; end REQUEST_PROLOGUE ; procedure DISPLAY_PROLOGUE ( PROLOGUE_NODE : in TREE_DATA.PROLOGUE_NODE_ACCESS_TYPE ) is -- ========================================================= -- This procedure displays the PROLOGUE -- ========================================================= BLANK_PROLOGUE_LINE : PROLOGUE_LINE := (others => ' ') ; PROMPT_LINE : PROLOGUE_LINE := BLANK_PROLOGUE_LINE ; begin PROMPT_LINE(19..33) := "Entity Prologue" ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( PROMPT_LINE , CURSOR_ADDRESS'(WRITE_WITH_ADDRESS), ROW_NO( 24-PROLOGUE_COUNT ), COL_NO( 1 ) ) ; for I in 1 .. PROLOGUE_COUNT loop -- display the previously entered lines VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( PROLOGUE(PROLOGUE_NODE).DATA(I) , CURSOR_ADDRESS'(WRITE_WITH_ADDRESS), ROW_NO( 24-(PROLOGUE_COUNT-I) ), COL_NO( 1 ) ) ; end loop ; end DISPLAY_PROLOGUE ; function SCOPE_SEARCH ( REFERENCE_POINT : in GRAPHICS_DATA.POINT ) return TREE_DATA.TREE_NODE_ACCESS_TYPE is -- ========================================================== -- Return a Tree Pointer to the Parent of the user -- specified reference point. The Parent is the object -- whose reference and size points contain the user -- specified reference point. -- ========================================================== use TREE_OPS ; PARENT : TREE_NODE_ACCESS_TYPE := ROOT_NODE ; NEW_PARENT : TREE_NODE_ACCESS_TYPE ; LIST_IN_PROGRESS : LIST_TYPE := CONTAINED_LIST ; LIST_PTR : LIST_NODE_ACCESS_TYPE ; function CHECK_LIST_FOR_ENCLOSURE ( LIST_HEAD : LIST_NODE_ACCESS_TYPE ) return TREE_NODE_ACCESS_TYPE is -- Check if any entities in the specified list enclose -- the reference point. Return the pointer to the enclosing -- tree node, and if none found, return the NULL_POINTER. LIST_PTR : LIST_NODE_ACCESS_TYPE := LIST_HEAD ; begin while LIST_PTR /= NULL_POINTER loop if SCOPE_CHECK (REFERENCE_POINT, LIST(LIST_PTR).ITEM) then -- found a closer containing object, which is now -- the best estimate of the Parent return LIST( LIST_PTR ).ITEM ; else -- check the next element in the list LIST_PTR := LIST( LIST_PTR ).NEXT ; end if ; end loop ; -- no enclosing entity found in the list return NULL_POINTER ; end CHECK_LIST_FOR_ENCLOSURE ; begin -- Check all the objects in the lists of the current -- parent to see if any of the children contain the point. -- Start from the CONTAINED_LIST of the ROOT. while LIST_IN_PROGRESS /= NULL_LIST loop LIST_PTR := GET_LIST_HEAD ( PARENT, LIST_IN_PROGRESS ) ; -- check if this list contain an entity containing -- the reference point NEW_PARENT := CHECK_LIST_FOR_ENCLOSURE( LIST_PTR ) ; if NEW_PARENT /= NULL_POINTER then -- a new enclosing entity has been found, -- search all its lists PARENT := NEW_PARENT ; LIST_IN_PROGRESS := START ; end if ; LIST_IN_PROGRESS := NEXT_LIST_TO_SCAN ( PARENT, LIST_IN_PROGRESS ) ; end loop ; -- check if the point is inside the body of the current parent begin if TREE(PARENT).NODE_TYPE in TYPE_VIRTUAL_PACKAGE .. TYPE_TASK then if SCOPE_CHECK (REFERENCE_POINT, TREE(PARENT).BODY_PTR) then PARENT := TREE(PARENT).BODY_PTR ; end if ; end if ; exception when others => -- continue with the old parent null ; end ; -- For PARENTS with contained entities -- check if the reference point is in the Exports , Imports, -- or Entry Points contained immediately within the current scope. begin if TREE( PARENT ).NODE_TYPE in ROOT .. TYPE_TASK then -- check all the contained entities LIST_PTR := GET_LIST_HEAD ( PARENT, CONTAINED_LIST ) ; while LIST_PTR /= NULL_POINTER loop -- check the Exports and Imports of Package (incl virtual) case TREE( LIST( LIST_PTR ).ITEM ).NODE_TYPE is when TYPE_VIRTUAL_PACKAGE .. TYPE_PACKAGE => -- check the Exports List NEW_PARENT := CHECK_LIST_FOR_ENCLOSURE ( GET_LIST_HEAD( LIST( LIST_PTR ).ITEM, EXPORTED_LIST ) ) ; if NEW_PARENT /= NULL_POINTER then PARENT := NEW_PARENT ; exit ; end if ; -- check the Imports List NEW_PARENT := CHECK_LIST_FOR_ENCLOSURE ( GET_LIST_HEAD( LIST( LIST_PTR ).ITEM, IMPORTED_LIST ) ) ; if NEW_PARENT /= NULL_POINTER then PARENT := NEW_PARENT ; exit ; end if ; when TYPE_TASK => -- check the Entry Points List NEW_PARENT := CHECK_LIST_FOR_ENCLOSURE ( GET_LIST_HEAD( LIST( LIST_PTR ).ITEM, ENTRY_LIST ) ) ; if NEW_PARENT /= NULL_POINTER then PARENT := NEW_PARENT ; exit ; end if ; when others => null ; end case ; -- check the next list element LIST_PTR := LIST( LIST_PTR ).NEXT ; end loop ; end if ; exception when others => -- continue with the old parent null ; end ; -- found the parent return PARENT ; end SCOPE_SEARCH ; function SCOPE_CHECK ( NEW_ENTITY_POINT : in GRAPHICS_DATA.POINT ; PARENT : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) return BOOLEAN is -- ========================================================== -- If the specified new entity being drawn is within the -- boundary of the Parent's reference and size points then -- return true; else return false. -- ========================================================== GRAPH_DATA : GRAPHICS_DATA.GRAPHICS_DATA_TYPE ; LOCATION : GRAPHICS_DATA.POINT ; SIZE : GRAPHICS_DATA.POINT ; begin -- check for a valid Parent pointer if PARENT = NULL_POINTER then -- checking non-existent scope return false ; elsif PARENT < NULL_POINTER or PARENT > MAX_TREE_NODES then TRACE_PKG.TRACE (" bad Parent pointer in SCOPE_CHECK " & INTEGER'image (PARENT) ) ; return false ; end if ; GRAPH_DATA := GRAPH(TREE(PARENT).GRAPH_DATA).DATA ; LOCATION := GRAPH_DATA.LOCATION ; SIZE := GRAPH_DATA.SIZE ; -- if the SIZE point is not defined then set it so that -- nothing will be selected if SIZE = NULL_POINT then SIZE := LOCATION ; end if ; -- check if the new entity point is bounded by the location -- and size points of the parent. if NEW_ENTITY_POINT.X > LOCATION.X and then NEW_ENTITY_POINT.Y < LOCATION.Y and then NEW_ENTITY_POINT.X < SIZE.X and then NEW_ENTITY_POINT.Y > SIZE.Y then return true ; else return false ; end if ; exception when others => TRACE_PKG.TRACE (" exception raised in SCOPE_CHECK ") ; return false ; end SCOPE_CHECK ; function CHECK_IF_GENERIC_INSTAN ( TREE_NODE : TREE_NODE_ACCESS_TYPE ) return BOOLEAN is -- ===================================================================== -- This procedure returns true if the TREE_NODE passed to it is -- a generic instantiation. -- ===================================================================== begin if TREE(TREE_NODE).GENERIC_STATUS = TREE_DATA.GENERIC_STATUS_TYPE'(GENERIC_INSTANTIATION) then return TRUE ; else return FALSE ; end if ; exception when others => -- handle TREE_NODEs for which GENERIC_STATUS is not defined return FALSE ; end CHECK_IF_GENERIC_INSTAN ; function GET_FIGURE_TYPE ( PARENT : ENTITY_TYPE ) return GRAPHICS_DATA.GRAPHIC_ENTITY is -- ========================================================= -- This procedure returns the figure_entity declaration -- for the corresponding entity_type declaration. -- ========================================================= begin case PARENT is when TYPE_VIRTUAL_PACKAGE => return GRAPHICS_DATA.GRAPHIC_ENTITY' ( VIRTUAL_PKG_FIGURE ) ; when TYPE_PACKAGE => return GRAPHICS_DATA.GRAPHIC_ENTITY' ( PACKAGE_FIGURE ) ; when TYPE_PROCEDURE => return GRAPHICS_DATA.GRAPHIC_ENTITY' ( SUBPROGRAM_FIGURE ) ; when TYPE_FUNCTION => return GRAPHICS_DATA.GRAPHIC_ENTITY' ( SUBPROGRAM_FIGURE ) ; when TYPE_TASK => return GRAPHICS_DATA.GRAPHIC_ENTITY' ( TASK_FIGURE ) ; when TYPE_BODY => return GRAPHICS_DATA.GRAPHIC_ENTITY' ( BODY_FIGURE ) ; when CONNECTION_BY_CALL => return GRAPHICS_DATA.GRAPHIC_ENTITY' ( CALL_CONNECT_LINE ) ; when CONNECTION_FOR_DATA => return GRAPHICS_DATA.GRAPHIC_ENTITY' ( DATA_CONNECT_LINE ) ; when others => raise UTILITY_FAILED ; end case ; end GET_FIGURE_TYPE ; function GET_LINE_TYPE ( PARENT : ENTITY_TYPE ) return GRAPHICS_DATA.LINE_ENTITY is -- ========================================================= -- This procedure returns the graphic_entity declaration -- for the corresponding entity_type declaration. -- ========================================================= begin case PARENT is when CONNECTION_BY_CALL => return GRAPHICS_DATA.LINE_ENTITY' ( CALL_CONNECT_LINE ) ; when CONNECTION_FOR_DATA => return GRAPHICS_DATA.LINE_ENTITY' ( DATA_CONNECT_LINE ) ; when others => -- EXPORTS return GRAPHICS_DATA.LINE_ENTITY' ( EXPORT_CONNECT_LINE ) ; end case ; end GET_LINE_TYPE ; procedure PICK_GRAPH_ENTITY ( PROMPT : in STRING ; GRAPH_NODE : in out TREE_DATA.GRAPH_NODE_ACCESS_TYPE ) is -- ========================================================= -- This procedure performs the prompt display and graph node -- lookup for a picked graphic entity. -- The routine exits with the window being -- the GRAPH_VIEW_PORT. -- ========================================================= BLANK_LINE : constant string := " " ; DONE : BOOLEAN := FALSE ; FOUND : BOOLEAN := FALSE ; REFERENCE_SEG_ID : GKS_SPECIFICATION.SEGMENT_NAME ; begin while not DONE loop begin -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; -- request the user identify the annotation VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( PROMPT , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- obtain closest segment id to the point REFERENCE_SEG_ID := GRAPHIC_DRIVER.PICK_SEGMENT ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( BLANK_LINE , FORMAT_FCT'( CLEAR_SCREEN ) , ROW_NO( 23 ) ) ; -- find the graph node pointer of the corresponding -- segment id FOUND := FALSE ; for GPTR in GRAPH'first .. GRAPH'last loop GRAPH_NODE := GPTR ; if ( GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID = REFERENCE_SEG_ID ) or ( GRAPH(GRAPH_NODE).DATA.SEGMENT_ID = REFERENCE_SEG_ID ) then FOUND := TRUE ; exit ; end if ; end loop ; if not FOUND then GRAPH_NODE := NULL_POINTER ; DISPLAY_ERROR ( "PROGRAM ERROR -- entity is not in the graph tree" ) ; else DONE := TRUE ; end if ; end ; end loop ; -- not DONE end PICK_GRAPH_ENTITY ; procedure DISPLAY_AND_IDENTIFY ( ENTITY_ITEM : ENTITY_TYPE ; ENTITY_NAME : TREE_DATA.NAME_TYPE ; LABEL_POINT : GRAPHICS_DATA.POINT ; SIZE_POINT : in out GRAPHICS_DATA.POINT ; COLOR : GRAPHICS_DATA.COLOR_TYPE ; REFERENCE_SEG_ID : in out GKS_SPECIFICATION.SEGMENT_NAME ) is -- ========================================================= -- This procedure displays the entity and returns the -- segment identifier. -- ========================================================= begin case ENTITY_ITEM is when EXPORTED_TYPE => GRAPHIC_DRIVER.LABEL ( REFERENCE_SEG_ID , SIZE_POINT , LABEL_POINT, TRUNCATE_NAME ( GRAPHICS_DATA.TYPE_DECL ( 1 ) & ENTITY_NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH ) & GRAPHICS_DATA.TYPE_DECL ( 2 ) , COLOR ) ; when EXPORTED_OBJECT => GRAPHIC_DRIVER.LABEL ( REFERENCE_SEG_ID , SIZE_POINT , LABEL_POINT, TRUNCATE_NAME ( GRAPHICS_DATA.OBJECT_DECL ( 1 ) & ENTITY_NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH ) & GRAPHICS_DATA.OBJECT_DECL ( 2 ) , COLOR ) ; when EXPORTED_EXCEPTION => GRAPHIC_DRIVER.LABEL ( REFERENCE_SEG_ID , SIZE_POINT , LABEL_POINT, TRUNCATE_NAME ( GRAPHICS_DATA.EXCEPTION_DECL ( 1 ) & ENTITY_NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH ) & GRAPHICS_DATA.EXCEPTION_DECL ( 2 ) , COLOR ) ; when IMPORTED_VIRTUAL_PACKAGE => GRAPHIC_DRIVER.LABEL ( REFERENCE_SEG_ID , SIZE_POINT , LABEL_POINT, TRUNCATE_NAME ( GRAPHICS_DATA.VIRT_PKG_DECL ( 1 ) & ENTITY_NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH ) & GRAPHICS_DATA.VIRT_PKG_DECL ( 2 ) , COLOR ) ; when IMPORTED_PACKAGE => GRAPHIC_DRIVER.LABEL ( REFERENCE_SEG_ID , SIZE_POINT , LABEL_POINT, TRUNCATE_NAME ( GRAPHICS_DATA.PKG_DECL ( 1 ) & ENTITY_NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH ) & GRAPHICS_DATA.PKG_DECL ( 2 ) , COLOR ) ; when IMPORTED_PROCEDURE | EXPORTED_PROCEDURE => GRAPHIC_DRIVER.LABEL ( REFERENCE_SEG_ID , SIZE_POINT , LABEL_POINT, TRUNCATE_NAME ( GRAPHICS_DATA.SUBPROG_DECL ( 1 ) & ENTITY_NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH ) & GRAPHICS_DATA.SUBPROG_DECL ( 2 ) , COLOR ) ; when IMPORTED_FUNCTION | EXPORTED_FUNCTION => GRAPHIC_DRIVER.LABEL ( REFERENCE_SEG_ID , SIZE_POINT , LABEL_POINT, TRUNCATE_NAME ( GRAPHICS_DATA.SUBPROG_DECL ( 1 ) & GRAPHICS_DATA.FUNCTION_SYMBOL & ENTITY_NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH ) & GRAPHICS_DATA.SUBPROG_DECL ( 2 ) , COLOR ) ; when TYPE_ENTRY_POINT | EXPORTED_ENTRY_POINT => GRAPHIC_DRIVER.LABEL ( REFERENCE_SEG_ID , SIZE_POINT , LABEL_POINT, TRUNCATE_NAME ( GRAPHICS_DATA.TASK_ENTRY_DECL ( 1 ) & ENTITY_NAME , GRAPHICS_DATA.LABEL_MAX_LENGTH ) & GRAPHICS_DATA.TASK_ENTRY_DECL ( 2 ) , COLOR ) ; when others => REFERENCE_SEG_ID := NULL_SEGMENT ; raise UTILITY_FAILED ; end case ; -- ENTITY_ITEM end DISPLAY_AND_IDENTIFY ; procedure PERFORM_SEGMENT_OP ( SEGMENT: in GKS_SPECIFICATION.SEGMENT_NAME ; OPERATION : in SEGMENT_OPS_TYPE ) is -- ========================================================= -- This procedure performs the selected operation on the -- specified segment. -- ========================================================= begin if SEGMENT /= NULL_SEGMENT then case OPERATION is when HILITED => GRAPHIC_DRIVER.HILITE_SEGMENT ( SEGMENT , GKS_SPECIFICATION.HIGHLIGHTED ); when DELETED => GRAPHIC_DRIVER.DELETE_SEGMENT (SEGMENT) ; when RESTORED => GRAPHIC_DRIVER.HILITE_SEGMENT ( SEGMENT , GKS_SPECIFICATION.NORMAL ); end case ; end if ; end PERFORM_SEGMENT_OP ; procedure PERFORM_LINE_OP ( TREE_POINTER : in TREE_DATA.TREE_NODE_ACCESS_TYPE ; OPERATION : in SEGMENT_OPS_TYPE ) is -- ========================================================= -- This procedure performs the selected operation on the -- line defined by TREE_POINTER. -- ========================================================= SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; begin -- operate on the line marker if TREE( TREE_POINTER ).NODE_TYPE = CONNECTION_BY_CALL or else TREE( TREE_POINTER ).NODE_TYPE = CONNECTION_FOR_DATA then if TREE( TREE_POINTER ).LINE( 1 ) /= NULL_POINTER then SEGMENT := GRAPH( TREE( TREE_POINTER ).LINE( 1 ) ). DATA.LABEL_SEG_ID ; PERFORM_SEGMENT_OP( SEGMENT, OPERATION ); end if ; -- null_pointer end if ; -- connection_by_call for I in 1 .. MAXIMUM_NO_LINE_SEGMENTS loop if TREE(TREE_POINTER).LINE(I) /= NULL_POINTER then SEGMENT := GRAPH(TREE(TREE_POINTER).LINE(I)).DATA.SEGMENT_ID ; PERFORM_SEGMENT_OP ( SEGMENT, OPERATION ); else -- null segment marks last point in line exit ; end if ; end loop ; end PERFORM_LINE_OP ; procedure PERFORM_GRAPH_TREE_OP ( PARENT : in TREE_DATA.TREE_NODE_ACCESS_TYPE ; OPERATION : in SEGMENT_OPS_TYPE ) is -- ========================================================= -- This procedure performs the selected operation on the -- subtree defined by PARENT. -- ========================================================= GPTR : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; LINE_TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; MEMBER_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; TREE_POINTER : TREE_DATA.TREE_NODE_ACCESS_TYPE ; WALK_STATE : TREE_OPS.WALK_STATE_TYPE ; begin -- set the window to graphics view port GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- highlight what is to be deleted TREE_OPS.START_TREE_WALK ( PARENT, WALK_STATE ) ; loop -- get the next node to be processed TREE_OPS.TREE_WALK ( WALK_STATE, TREE_POINTER ) ; exit when TREE_POINTER = NULL_POINTER ; -- get the graph node and perform the operations -- on each of the segments GPTR := TREE(TREE_POINTER).GRAPH_DATA ; if GPTR /= NULL_POINTER then PERFORM_SEGMENT_OP( GRAPH(GPTR).DATA.SEGMENT_ID, OPERATION ); PERFORM_SEGMENT_OP( GRAPH(GPTR).DATA.LABEL_SEG_ID, OPERATION ); PERFORM_SEGMENT_OP( GRAPH(GPTR).DATA.LABEL2_SEG_ID, OPERATION ); end if ; -- check if node contains a line if TREE(TREE_POINTER).NODE_TYPE in EXPORTED_PROCEDURE .. CONNECTION_FOR_DATA then PERFORM_LINE_OP( TREE_POINTER, OPERATION ) ; end if ; -- check if node is referenced by a line MEMBER_PTR := TREE(TREE_POINTER).MEMBERSHIP ; while MEMBER_PTR /= NULL_POINTER loop if LIST(MEMBER_PTR).ITEM /= TREE(TREE_POINTER).PARENT then LINE_TREE_NODE := LIST( MEMBER_PTR ).ITEM ; if TREE(LINE_TREE_NODE).CONNECTEE = TREE_POINTER then -- operate on exported entry points in there entirety if TREE(LINE_TREE_NODE).NODE_TYPE = EXPORTED_ENTRY_POINT then PERFORM_GRAPH_TREE_OP ( LINE_TREE_NODE, OPERATION ) ; else -- operate on the segments forming the connecting line PERFORM_LINE_OP( LINE_TREE_NODE, OPERATION ); end if ; end if ; -- connectee = tree=pointer end if ; -- get next membership list node MEMBER_PTR := LIST( MEMBER_PTR ).NEXT ; end loop ; -- MEMBER_PTR /= NULL_POINTER end loop ; end PERFORM_GRAPH_TREE_OP ; procedure VIEW_WINDOW_CHECK ( PARENT : in TREE_NODE_ACCESS_TYPE ) is -- ======================================================== -- Assure that the entire subtree defined by the specified -- parent is visible on the view window. -- ======================================================== GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; LINE_TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; UPPER_LEFT_PT : GRAPHICS_DATA.POINT ; LOWER_RIGHT_PT : GRAPHICS_DATA.POINT ; LINE_PT : GRAPHICS_DATA.POINT ; WALK_STATE : TREE_OPS.WALK_STATE_TYPE ; MEMBER_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; begin TREE_OPS.START_TREE_WALK ( PARENT, WALK_STATE ) ; VIEW_CHECK: loop -- walk the tree until all nodes have been processed TREE_OPS.TREE_WALK ( WALK_STATE, TREE_NODE ) ; exit VIEW_CHECK when TREE_NODE = NULL_POINTER ; if TREE( TREE_NODE ).GRAPH_DATA /= NULL_POINTER then -- the basic points of the associate graph node GRAPH_NODE := TREE( TREE_NODE ).GRAPH_DATA ; LOWER_RIGHT_PT := GRAPH( GRAPH_NODE ).DATA.SIZE ; if LOWER_RIGHT_PT /= NULL_POINT and then not LOCATION_IN_GRAPHIC_VIEWPORT( LOWER_RIGHT_PT ) then -- zoom out GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( ON ) ; GRAPHIC_DRIVER.ZOOM( GRAPHICS_DATA.MAX_ZOOM_OUT ) ; GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( OFF ) ; exit VIEW_CHECK ; end if; UPPER_LEFT_PT := GRAPH( GRAPH_NODE ).DATA.LOCATION ; if not LOCATION_IN_GRAPHIC_VIEWPORT( UPPER_LEFT_PT ) then -- zoom out GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( ON ) ; GRAPHIC_DRIVER.ZOOM( GRAPHICS_DATA.MAX_ZOOM_OUT ) ; GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( OFF ) ; exit VIEW_CHECK ; end if; end if ; -- if a connection exists, then check the connection points if TREE( TREE_NODE ).NODE_TYPE in EXPORTED_PROCEDURE .. CONNECTION_FOR_DATA then for I in 1 .. MAXIMUM_NO_LINE_SEGMENTS loop GRAPH_NODE := TREE( TREE_NODE ).LINE(I) ; if GRAPH_NODE = NULL_POINTER then exit ; else LINE_PT := GRAPH( GRAPH_NODE ).DATA.LOCATION ; if not LOCATION_IN_GRAPHIC_VIEWPORT( LINE_PT ) then -- zoom out GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( ON ) ; GRAPHIC_DRIVER.ZOOM( GRAPHICS_DATA.MAX_ZOOM_OUT ) ; GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( OFF ) ; exit VIEW_CHECK ; end if; end if ; end loop ; end if ; -- check if node is referenced by a line MEMBER_PTR := TREE(TREE_NODE).MEMBERSHIP ; while MEMBER_PTR /= NULL_POINTER loop if LIST(MEMBER_PTR).ITEM /= TREE(TREE_NODE).PARENT then LINE_TREE_NODE := LIST( MEMBER_PTR ).ITEM ; if TREE(LINE_TREE_NODE).CONNECTEE = TREE_NODE then -- operate on the segments forming the connecting line -- operate on the size point of connecting export if TREE( LINE_TREE_NODE ).NODE_TYPE in EXPORTED_PROCEDURE .. EXPORTED_EXCEPTION then LINE_PT := GRAPH( TREE( LINE_TREE_NODE ). GRAPH_DATA ).DATA.SIZE ; if not LOCATION_IN_GRAPHIC_VIEWPORT( LINE_PT ) then -- zoom out GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( ON ) ; GRAPHIC_DRIVER.ZOOM( GRAPHICS_DATA.MAX_ZOOM_OUT ) ; GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( OFF ) ; exit VIEW_CHECK ; end if; end if ; -- EXPORT for I in 1 .. MAXIMUM_NO_LINE_SEGMENTS loop if TREE(LINE_TREE_NODE).LINE(I) /= NULL_POINTER then LINE_PT := GRAPH(TREE(LINE_TREE_NODE). LINE(I)).DATA.LOCATION ; if not LOCATION_IN_GRAPHIC_VIEWPORT( LINE_PT ) then -- zoom out GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( ON ) ; GRAPHIC_DRIVER.ZOOM( GRAPHICS_DATA.MAX_ZOOM_OUT ) ; GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( OFF ) ; exit VIEW_CHECK ; end if; else -- null segment marks last point in line exit ; end if ; end loop ; end if ; -- connectee = tree_node end if ; -- get next membership list node MEMBER_PTR := LIST( MEMBER_PTR ).NEXT ; end loop ; -- MEMBER_PTR /= NULL_POINTER end loop VIEW_CHECK ; end VIEW_WINDOW_CHECK ; end UTIL_FOR_TREE ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --mmi_control_menus_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-02-06 1005 BY JL with MMI_PARAMETERS ; use MMI_PARAMETERS ; package MMI_CONTROL_MENUS is -- ============================================================= -- -- This package contains the menu control subprograms -- used by the Design functions of the Man-Machine -- Interface. -- -- ============================================================= function CONTROL_PAN_ZOOM_MENU return COMMAND_TYPE ; -- ========================================================= -- This function performs operations required to implement -- the pan/zoom menu commands, always returns BACKUP_CMD. -- ========================================================= function CONTROL_GENERIC_MENU return COMMAND_TYPE ; -- ========================================================= -- This function performs operations required to input -- the generic menu commands. -- ========================================================= function CONTROL_PARAMETER_STATUS_MENU return COMMAND_TYPE ; -- ========================================================= -- This function performs operations required to input -- the parameter status menu commands. -- ========================================================= function CONTROL_CALL_STATUS_MENU return COMMAND_TYPE ; -- ========================================================= -- This function performs operations required to input -- the call status menu commands. -- ========================================================= function CONTROL_ENTRY_POINT_STATUS_MENU return COMMAND_TYPE ; -- ========================================================= -- This function performs operations required to input -- the entry point status menu commands. -- ========================================================= function CONTROL_PDL_STATUS_MENU return COMMAND_TYPE ; -- ========================================================= -- This function performs operations required to input -- the PDL status menu commands. -- ========================================================= function CONTROL_DELETE_MENU return COMMAND_TYPE ; -- ========================================================== -- This function returns a CONFIRM_CMD or a CANCEL_CMD. -- ========================================================== procedure DELETE_CONNECTION ; -- ========================================================= -- This procedure performs operations required to implement -- the delete operations. -- ========================================================= procedure DELETE ; -- ========================================================= -- This procedure performs operations required to implement -- the delete operations. -- ========================================================= function CHECK_IF_ANNOTATED_TREE_VALID return BOOLEAN ; -- ========================================================= -- This function will check the tree representation of the -- graph. If any inconsistencies (overlaps) exist, the -- function will display an error message and then -- return false. -- ========================================================= procedure MOVE_AND_RESIZE ; -- ========================================================= -- This procedure prompts the user for information -- which will allow portions of the OODDs to be -- moved or resized within their current scope. -- ========================================================= end MMI_CONTROL_MENUS ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --mmi_control_menus_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-02-10 16:10 by JL with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; with GRAPHICS_DATA ; use GRAPHICS_DATA ; with GRAPHIC_DRIVER ; use GRAPHIC_DRIVER ; with TEXT_IO ; with TRACE_PKG ; with TREE_DATA ; use TREE_DATA ; with TREE_OPS ; use TREE_OPS ; with UTILITIES ; use UTILITIES ; with UTIL_FOR_TREE ; use UTIL_FOR_TREE ; with VIRTUAL_TERMINAL_INTERFACE ; package body MMI_CONTROL_MENUS is function CONTROL_PAN_ZOOM_MENU return COMMAND_TYPE is -- ========================================================= -- This procedure performs operations required to implement -- the pan/zoom menu commands. -- ========================================================= COMMAND : COMMAND_TYPE := COMMAND_TYPE'( PAN_UP_CMD ) ; DONE : BOOLEAN := FALSE ; begin -- place graphic viewport in pan and zoom display GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( ON ) ; while not DONE loop begin -- display the current menu and get command DISPLAY_MENU_AND_GET_COMMAND( MENU_ID'( PAN_ZOOM_MENU ) , COMMAND ) ; case COMMAND is -- implement the menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( PAN_ZOOM_MENU ) ) ; when BACKUP_CMD => -- return to the next higher menu DONE := true ; -- exit the loop when PAN_UP_CMD => GRAPHIC_DRIVER.PAN ( GRAPHICS_DATA.PAN_UP ) ; when PAN_DOWN_CMD => GRAPHIC_DRIVER.PAN ( GRAPHICS_DATA.PAN_DOWN ) ; when PAN_LEFT_CMD => GRAPHIC_DRIVER.PAN ( GRAPHICS_DATA.PAN_LEFT ) ; when PAN_RIGHT_CMD => GRAPHIC_DRIVER.PAN ( GRAPHICS_DATA.PAN_RIGHT ) ; when ZOOM_IN_CMD => GRAPHIC_DRIVER.ZOOM ( GRAPHICS_DATA.ZOOM_IN ) ; when ZOOM_OUT_CMD => GRAPHIC_DRIVER.ZOOM ( GRAPHICS_DATA.ZOOM_OUT ) ; when MAX_PAN_UP_CMD => GRAPHIC_DRIVER.PAN ( GRAPHICS_DATA.MAX_PAN_UP ) ; when MAX_PAN_DOWN_CMD => GRAPHIC_DRIVER.PAN ( GRAPHICS_DATA.MAX_PAN_DOWN ) ; when MAX_PAN_LEFT_CMD => GRAPHIC_DRIVER.PAN ( GRAPHICS_DATA.MAX_PAN_LEFT ) ; when MAX_PAN_RIGHT_CMD => GRAPHIC_DRIVER.PAN ( GRAPHICS_DATA.MAX_PAN_RIGHT ) ; when MAX_ZOOM_IN_CMD => GRAPHIC_DRIVER.ZOOM ( GRAPHICS_DATA.MAX_ZOOM_IN ) ; when MAX_ZOOM_OUT_CMD => GRAPHIC_DRIVER.ZOOM ( GRAPHICS_DATA.MAX_ZOOM_OUT ) ; when others => -- this should not occur null ; end case ; -- COMMAND exception when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in PAN_ZOOM_MENU ") ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; end ; end loop ; -- place graphic viewport in graphic display GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( OFF ) ; -- return the BACKUP command return COMMAND ; end CONTROL_PAN_ZOOM_MENU ; function CONTROL_GENERIC_MENU return COMMAND_TYPE is -- ========================================================= -- This procedure performs operations required to input -- the generic menu commands. -- ========================================================= COMMAND : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DONE : BOOLEAN := FALSE ; begin while not DONE loop begin -- pre place icon cursor on non_generic_cmd COMMAND := NON_GENERIC_CMD ; -- display the current menu and get command from GRAPHICS_DRIVER DISPLAY_MENU_AND_GET_COMMAND( MENU_ID'( GENERIC_MENU ) , COMMAND ) ; case COMMAND is -- process the menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( GENERIC_MENU ) ) ; when BACKUP_CMD => -- return to the next higher menu raise HANDLE_ABORT_BACKUP ; when GENERIC_MENU_CMD => -- return the selected generic status DONE := true ; -- exit the loop when others => -- this should not occur null ; end case ; -- COMMAND exception when HANDLE_ABORT_BACKUP => -- propagate to return raise ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in GENERIC_MENU ") ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; end ; end loop ; -- return the command processed return COMMAND ; end CONTROL_GENERIC_MENU ; function CONTROL_PARAMETER_STATUS_MENU return COMMAND_TYPE is -- ========================================================= -- This procedure performs operations required to input -- the parameter status menu commands. -- ========================================================= COMMAND : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DONE : BOOLEAN := FALSE ; begin while not DONE loop begin -- pre place icon cursor on has_parameters COMMAND := HAS_PARAMETERS_CMD ; -- display the current menu and get command from GRAPHICS_DRIVER DISPLAY_MENU_AND_GET_COMMAND ( MENU_ID'( PARAMETER_STATUS_MENU ) , COMMAND ) ; case COMMAND is -- input the menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( PARAMETER_STATUS_MENU ) ) ; when BACKUP_CMD => -- return to the next higher menu raise HANDLE_ABORT_BACKUP ; when PARAMETER_STATUS_MENU_CMD => -- return the selected parameter status DONE := true ; -- exit the loop when others => -- this should not occur null ; end case ; -- COMMAND exception when HANDLE_ABORT_BACKUP => -- propagate to return raise ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in PARAMETER_STATUS_MENU ") ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; end ; end loop ; -- return the command processed return COMMAND ; end CONTROL_PARAMETER_STATUS_MENU ; function CONTROL_CALL_STATUS_MENU return COMMAND_TYPE is -- ========================================================= -- This procedure performs operations required to input -- the call status menu commands. -- ========================================================= COMMAND : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DONE : BOOLEAN := FALSE ; begin while not DONE loop begin -- pre place icon cursor on unconditional COMMAND := UNCONDITIONAL_CMD ; -- display the current menu and get command from GRAPHICS_DRIVER DISPLAY_MENU_AND_GET_COMMAND ( MENU_ID'( CALL_STATUS_MENU ) , COMMAND ) ; case COMMAND is -- input the menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( CALL_STATUS_MENU ) ) ; when BACKUP_CMD => -- return to the next higher menu raise HANDLE_ABORT_BACKUP ; when CALL_STATUS_MENU_CMD => -- return the selected call status DONE := true ; -- exit the loop when others => -- this should not occur null ; end case ; -- COMMAND exception when HANDLE_ABORT_BACKUP => -- propagate to return raise ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in CALL_STATUS_MENU ") ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; end ; end loop ; -- return the command processed return COMMAND ; end CONTROL_CALL_STATUS_MENU ; function CONTROL_ENTRY_POINT_STATUS_MENU return COMMAND_TYPE is -- ========================================================= -- This procedure performs operations required to input -- the entry point status menu commands. -- ========================================================= COMMAND : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DONE : BOOLEAN := FALSE ; begin while not DONE loop begin -- pre place icon cursor on unguarded COMMAND := UNGUARDED_CMD ; -- display the current menu and get command from GRAPHICS_DRIVER DISPLAY_MENU_AND_GET_COMMAND ( MENU_ID'( ENTRY_POINT_STATUS_MENU ), COMMAND ) ; case COMMAND is -- implement the menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( ENTRY_POINT_STATUS_MENU ) ) ; when BACKUP_CMD => -- return to the next higher menu raise HANDLE_ABORT_BACKUP ; when ENTRY_POINT_STATUS_MENU_CMD => -- return the selected entry point status DONE := true ; -- exit the loop when others => -- this should not occur null ; end case ; -- COMMAND exception when HANDLE_ABORT_BACKUP => -- propagate to return raise ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in ENTRY_POINT_STATUS_MENU ") ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; end ; end loop ; -- return the command processed return COMMAND ; end CONTROL_ENTRY_POINT_STATUS_MENU ; function CONTROL_PDL_STATUS_MENU return COMMAND_TYPE is -- ========================================================= -- This procedure performs operations required to input -- the PLD status menu commands. -- ========================================================= COMMAND : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DONE : BOOLEAN := FALSE ; begin while not DONE loop begin -- pre place icon cursor on unguarded COMMAND := WITH_SUPPORT_CMD ; -- display the current menu and get command from GRAPHICS_DRIVER DISPLAY_MENU_AND_GET_COMMAND ( MENU_ID'( PDL_STATUS_MENU ), COMMAND ) ; case COMMAND is -- implement the menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( PDL_STATUS_MENU ) ) ; when BACKUP_CMD => -- return to the next higher menu raise HANDLE_ABORT_BACKUP ; when PDL_STATUS_MENU_CMD => -- return the selected entry point status DONE := true ; -- exit the loop when others => -- this should not occur null ; end case ; -- COMMAND exception when HANDLE_ABORT_BACKUP => -- propagate to return raise ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in PDL_STATUS_MENU ") ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; end ; end loop ; -- return the command processed return COMMAND ; end CONTROL_PDL_STATUS_MENU ; function CONTROL_DELETE_MENU return COMMAND_TYPE is -- ========================================================== -- This function returns a CONFIRM_CMD or a CANCEL_CMD. -- ========================================================== COMMAND : COMMAND_TYPE := CANCEL_CMD ; DONE : BOOLEAN := FALSE ; begin while not DONE loop begin -- pre place icon cursor on cancel_cmd COMMAND := CANCEL_CMD ; -- confirm item to be deleted DISPLAY_MENU_AND_GET_COMMAND( MENU_ID'( DELETE_MENU ) , COMMAND ) ; case COMMAND is -- implement the menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( DELETE_MENU ) ) ; when BACKUP_CMD => -- abort the current command DONE := true ; when DELETE_MENU_CMD => -- the operation is confirmed or canceled DONE := true ; when others => -- invalid selection - try again null ; end case ; -- COMMAND exception when others => -- handle the error condition DISPLAY_ERROR (" PROGRAM ERROR -- in DELETE_MENU ") ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; end ; end loop ; -- return the selection confirm or cancel return COMMAND ; end CONTROL_DELETE_MENU ; procedure DELETE is -- ========================================================= -- This procedure performs operations required to implement -- the delete operation. -- ========================================================= DONE : BOOLEAN := false ; GPTR : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; REFERENCE_POINT : GRAPHICS_DATA.POINT ; STATUS : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; ERROR_DELETE_ROOT : EXCEPTION ; begin -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; -- turn on abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- request the user identify the scope to be deleted REQUEST_POINT (" enter point identifying scope to be deleted", REFERENCE_POINT, PARENT ) ; -- turn off abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for a valid parent if PARENT = ROOT_NODE then raise ERROR_DELETE_ROOT ; elsif PARENT /= NULL_POINTER then -- verify that graph entities are in full view VIEW_WINDOW_CHECK( PARENT ) ; -- highlight what is to be deleted PERFORM_GRAPH_TREE_OP ( PARENT, HILITED ) ; -- display prologue if available if TREE(PARENT).NODE_TYPE in TYPE_VIRTUAL_PACKAGE..TYPE_TASK then VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( TREE( PARENT ).NAME , VIRTUAL_TERMINAL_INTERFACE.CENTER_A_LINE , ROW_NO( 23 ) ) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " is the scope of influence for the delete " , VIRTUAL_TERMINAL_INTERFACE.CENTER_A_LINE , ROW_NO( 24 ) ) ; end if ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; -- request user confirm of deletion STATUS := CONTROL_DELETE_MENU ; -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- process the results of the confirmation if STATUS = CONFIRM_CMD then -- delete what was highlighted PERFORM_GRAPH_TREE_OP ( PARENT, DELETED ) ; TREE_OPS.RELEASE_TREE_NODE (PARENT) ; -- refresh screen to eliminate any broken lines GRAPHIC_DRIVER.REFRESH_SCREEN ; else -- restore the diagram PERFORM_GRAPH_TREE_OP ( PARENT, RESTORED ) ; end if ; end if ; -- process with valid parent -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; exception when ERROR_DELETE_ROOT => DISPLAY_ERROR ("illegal to delete the outer scope") ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; when OPERATION_ABORTED_BY_OPERATOR => -- turn off abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in attempted delete, nothing deleted ") ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; end DELETE ; procedure DELETE_CONNECTION is -- ========================================================= -- This procedure performs operations required to implement -- the delete connection operation. -- ========================================================= DONE : BOOLEAN := false ; GPTR : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; LIST_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; REFERENCE_POINT : GRAPHICS_DATA.POINT ; START_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; START_POINT : GRAPHICS_DATA.POINT ; END_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; END_POINT : GRAPHICS_DATA.POINT ; STATUS : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; ERROR_DELETE_CONNECT : EXCEPTION ; ERROR_DELETE_ENTRY_PT_CONNECT : EXCEPTION ; begin -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; -- turn on abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- request the user identify the line starting scope to be deleted REQUEST_POINT ("enter within caller(starting) scope for connection to be deleted", START_POINT , START_PARENT ) ; -- turn off abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for a valid parent if START_PARENT = ROOT_NODE or START_PARENT = NULL_POINTER then raise ERROR_DELETE_CONNECT ; else case TREE(START_PARENT).NODE_TYPE is -- only one line possible when EXPORTED_PROCEDURE..EXPORTED_EXCEPTION => if TREE(START_PARENT).NODE_TYPE = EXPORTED_ENTRY_POINT then -- error, don't allow delete connection raise ERROR_DELETE_ENTRY_PT_CONNECT ; elsif TREE(START_PARENT).LINE = NULL_LINE then -- error, no line exist raise ERROR_DELETE_CONNECT ; end if ; -- highlight line is to be deleted PERFORM_LINE_OP( START_PARENT, HILITED ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; -- request user confirm of deletion STATUS := CONTROL_DELETE_MENU ; -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; -- process the results of the confirmation if STATUS = CONFIRM_CMD then -- delete what was highlighted PERFORM_LINE_OP( START_PARENT, DELETED ) ; -- delete the tree data -- release the line graph nodes for I in 1 .. MAXIMUM_NO_LINE_SEGMENTS loop if TREE( START_PARENT ).LINE(I) /= NULL_POINTER then RELEASE_GRAPH_NODE(TREE( START_PARENT ).LINE(I)); else exit ; end if ; end loop ; TREE_OPS.BREAK_REFERENCE (START_PARENT , TREE(START_PARENT).CONNECTEE ) ; TREE(START_PARENT).CONNECTEE := NULL_POINTER ; TREE(START_PARENT).LINE := NULL_LINE ; -- refresh screen to eliminate any broken lines GRAPHIC_DRIVER.REFRESH_SCREEN ; else -- restore the diagram PERFORM_LINE_OP( START_PARENT, RESTORED ) ; end if ; when others => begin -- more than one line is possible case TREE(START_PARENT).NODE_TYPE is when TYPE_BODY => LIST_PTR := GET_LIST_HEAD(START_PARENT , CALLEE_LIST ) ; when others => LIST_PTR := GET_LIST_HEAD(START_PARENT , DATA_CONNECT_LIST ) ; end case ; exception when others => -- start parent doesn't have data connect list -- propogate to display error raise ERROR_DELETE_CONNECT ; end ; if LIST_PTR = NULL_POINTER then -- error, no line exist raise ERROR_DELETE_CONNECT ; end if ; if LIST(LIST_PTR).NEXT /= NULL_POINTER then -- turn on abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ); -- more than one line, get ending point REQUEST_POINT ("enter within callee(ending) scope for connection to be deleted", END_POINT , END_PARENT ) ; -- turn off abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF); -- scan callee list to match end parent loop TREE_NODE := LIST(LIST_PTR).ITEM ; exit when TREE(TREE_NODE).CONNECTEE = END_PARENT ; LIST_PTR := LIST(LIST_PTR).NEXT ; if LIST_PTR = NULL_POINTER then -- error, no matching line exists raise ERROR_DELETE_CONNECT ; end if ; end loop ; end if ; PARENT := LIST(LIST_PTR).ITEM ; -- highlight what is to be deleted PERFORM_GRAPH_TREE_OP ( PARENT, HILITED ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; -- request user confirm of deletion STATUS := CONTROL_DELETE_MENU ; -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; -- process the results of the confirmation if STATUS = CONFIRM_CMD then -- delete what was highlighted PERFORM_GRAPH_TREE_OP ( PARENT, DELETED ) ; TREE_OPS.RELEASE_TREE_NODE (PARENT) ; else -- restore the diagram PERFORM_GRAPH_TREE_OP ( PARENT, RESTORED ) ; end if ; end case ; end if ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; exception when ERROR_DELETE_CONNECT => DISPLAY_ERROR ("invalid, no corresponding connection exists") ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; when ERROR_DELETE_ENTRY_PT_CONNECT => DISPLAY_ERROR ("invalid, cannot delete connection, must delete exported entry point") ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; when OPERATION_ABORTED_BY_OPERATOR => -- turn off abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in attempted delete, nothing deleted ") ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; end DELETE_CONNECTION ; function CHECK_IF_ANNOTATED_TREE_VALID return BOOLEAN is -- Return true if the tree is valid as currently defined. -- The validity check will determine if the locations -- of the graph entities are consistent with the semantic -- information of the tree. GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; TREE_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; TREE_PARENTS_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; TREE_PTR : TREE_DATA.TREE_NODE_ACCESS_TYPE ; WALK_STATE : TREE_OPS.WALK_STATE_TYPE ; UPPER_LEFT_POINT, LOWER_LEFT_POINT, UPPER_RIGHT_POINT, LOWER_RIGHT_POINT : GRAPHICS_DATA.POINT ; begin START_TREE_WALK ( ROOT_NODE, WALK_STATE ) ; loop TREE_WALK ( WALK_STATE, TREE_PTR ) ; exit when TREE_PTR = NULL_POINTER ; case TREE( TREE_PTR ).NODE_TYPE is when TYPE_VIRTUAL_PACKAGE .. TYPE_TASK | TYPE_BODY => GRAPH_NODE := TREE( TREE_PTR ).GRAPH_DATA ; TREE_PARENT := TREE( TREE_PTR ).PARENT ; UPPER_LEFT_POINT := GRAPH( GRAPH_NODE ).DATA.LOCATION ; UPPER_LEFT_POINT.Y := UPPER_LEFT_POINT.Y + 1 ; LOWER_RIGHT_POINT := GRAPH( GRAPH_NODE ).DATA.SIZE ; LOWER_RIGHT_POINT.Y := LOWER_RIGHT_POINT.Y - 1 ; LOWER_LEFT_POINT := (X => UPPER_LEFT_POINT.X , Y => LOWER_RIGHT_POINT.Y ) ; UPPER_RIGHT_POINT := (X => LOWER_RIGHT_POINT.X , Y => UPPER_LEFT_POINT.Y ) ; if SCOPE_SEARCH( UPPER_LEFT_POINT ) /= TREE_PARENT or else SCOPE_SEARCH ( LOWER_RIGHT_POINT ) /= TREE_PARENT or else SCOPE_SEARCH ( LOWER_LEFT_POINT ) /= TREE_PARENT or else SCOPE_SEARCH ( UPPER_RIGHT_POINT ) /= TREE_PARENT then -- the entity location and tree information -- are inconsistent -- since the body nodes don't have names if TREE( TREE_PTR ).NODE_TYPE = TYPE_BODY then VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " the body of " & TREE( TREE (TREE_PTR ).PARENT ).NAME(1..15) & " will overlap another entity(improper scoping) " , VIRTUAL_TERMINAL_INTERFACE.CENTER_A_LINE , ROW_NO( 23 ) ) ; else VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( TREE( TREE_PTR ).NAME(1..15) & " will overlap another entity(improper scoping) " , VIRTUAL_TERMINAL_INTERFACE.CENTER_A_LINE , ROW_NO( 23 ) ) ; end if ; return false ; end if ; when IMPORTED_VIRTUAL_PACKAGE .. IMPORTED_FUNCTION => GRAPH_NODE := TREE( TREE_PTR ).GRAPH_DATA ; TREE_PARENT := TREE( TREE_PTR ).PARENT ; TREE_PARENTS_PARENT := TREE( TREE_PARENT ).PARENT ; UPPER_LEFT_POINT := GRAPH( GRAPH_NODE ).DATA.LOCATION ; UPPER_LEFT_POINT.Y := UPPER_LEFT_POINT.Y + 1 ; LOWER_RIGHT_POINT := GRAPH( GRAPH_NODE ).DATA.SIZE ; LOWER_RIGHT_POINT.Y := LOWER_RIGHT_POINT.Y - 1 ; LOWER_LEFT_POINT := (X => UPPER_LEFT_POINT.X , Y => LOWER_RIGHT_POINT.Y ) ; UPPER_RIGHT_POINT := (X => LOWER_RIGHT_POINT.X , Y => UPPER_LEFT_POINT.Y ) ; if SCOPE_SEARCH( UPPER_LEFT_POINT ) /= TREE_PARENT or else SCOPE_SEARCH ( LOWER_RIGHT_POINT ) /= TREE_PARENTS_PARENT or else SCOPE_SEARCH ( LOWER_LEFT_POINT ) /= TREE_PARENT or else SCOPE_SEARCH ( UPPER_RIGHT_POINT ) /= TREE_PARENTS_PARENT then -- the entity location and tree information -- are inconsistent VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " the import " & TREE( TREE_PTR ).NAME(1..15) & " will overlap another entity(improper scoping) " , VIRTUAL_TERMINAL_INTERFACE.CENTER_A_LINE , ROW_NO( 23 ) ) ; return false ; end if ; when EXPORTED_PROCEDURE .. EXPORTED_EXCEPTION => GRAPH_NODE := TREE( TREE_PTR ).GRAPH_DATA ; TREE_PARENT := TREE( TREE_PTR ).PARENT ; TREE_PARENTS_PARENT := TREE( TREE_PARENT ).PARENT ; UPPER_LEFT_POINT := GRAPH( GRAPH_NODE ).DATA.LOCATION ; UPPER_LEFT_POINT.Y := UPPER_LEFT_POINT.Y + 1 ; LOWER_RIGHT_POINT := GRAPH( GRAPH_NODE ).DATA.SIZE ; LOWER_RIGHT_POINT.Y := LOWER_RIGHT_POINT.Y - 1 ; LOWER_LEFT_POINT := (X => UPPER_LEFT_POINT.X , Y => LOWER_RIGHT_POINT.Y ) ; UPPER_RIGHT_POINT := (X => LOWER_RIGHT_POINT.X , Y => UPPER_LEFT_POINT.Y ) ; if SCOPE_SEARCH( UPPER_LEFT_POINT ) /= TREE_PARENTS_PARENT or else SCOPE_SEARCH ( LOWER_RIGHT_POINT ) /= TREE_PARENT or else SCOPE_SEARCH ( LOWER_LEFT_POINT ) /= TREE_PARENTS_PARENT or else SCOPE_SEARCH ( UPPER_RIGHT_POINT ) /= TREE_PARENT then -- the entity location and tree information -- are inconsistent VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " the export " & TREE( TREE_PTR ).NAME(1..15) & " will overlap another entity(improper scoping) " , VIRTUAL_TERMINAL_INTERFACE.CENTER_A_LINE , ROW_NO( 23 ) ) ; return false ; end if ; when TYPE_ENTRY_POINT => GRAPH_NODE := TREE( TREE_PTR ).GRAPH_DATA ; TREE_PARENT := TREE( TREE_PTR ).PARENT ; UPPER_LEFT_POINT := GRAPH( GRAPH_NODE ).DATA.LOCATION ; UPPER_LEFT_POINT.Y := UPPER_LEFT_POINT.Y + 1 ; LOWER_RIGHT_POINT := GRAPH( GRAPH_NODE ).DATA.SIZE ; LOWER_RIGHT_POINT.Y := LOWER_RIGHT_POINT.Y - 1 ; UPPER_RIGHT_POINT := (X => LOWER_RIGHT_POINT.X , Y => UPPER_LEFT_POINT.Y ) ; -- for entries just check the right side points if SCOPE_SEARCH( LOWER_RIGHT_POINT ) /= TREE_PARENT or else SCOPE_SEARCH ( UPPER_RIGHT_POINT ) /= TREE_PARENT then -- the entity location and tree information -- are inconsistent VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " the entry point " & TREE( TREE_PTR ).NAME(1..15) & " will overlap another entity(improper scoping) " , VIRTUAL_TERMINAL_INTERFACE.CENTER_A_LINE , ROW_NO( 23 ) ) ; return false ; end if ; when others => -- call and visibility connects null ; end case ; end loop ; -- the tree is consistent, return true return true ; exception when others => DISPLAY_ERROR (" PROGRAM ERROR -- in checking tree validity ") ; return false ; end CHECK_IF_ANNOTATED_TREE_VALID ; procedure MOVE_AND_RESIZE is -- This procedure prompts the user for information -- which will allow portions of the OODDs to be -- moved nad resized within their current scope. BASE_POINT : GRAPHICS_DATA.POINT ; CHECK_POINT : GRAPHICS_DATA.POINT ; GPTR : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; PARENT_TASK_GPTR : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; OOS_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; TEMP_LIST_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; TEMP_LIST_HEAD_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; OLD_SCOPE_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; OOS_MOVE : BOOLEAN := false ; MOVE_OK : BOOLEAN ; LABEL_ONLY : BOOLEAN := false ; IMPORT_LABEL : BOOLEAN := false ; NEW_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; OLD_SIZE_POINT : GRAPHICS_DATA.POINT ; TEMPORARY_POINT : GRAPHICS_DATA.POINT ; REFERENCE_POINT : GRAPHICS_DATA.POINT ; MOVE_REFERENCE_POINT : GRAPHICS_DATA.POINT ; RESIZE_REFERENCE_POINT : GRAPHICS_DATA.POINT ; MOVE_X_TRANSLATION : FLOAT ; MOVE_Y_TRANSLATION : FLOAT ; RESIZE_X_TRANSLATION : FLOAT ; RESIZE_Y_TRANSLATION : FLOAT ; -- establish lists for storing connection information -- within the move and resize subtype TEMP_LIST_NODE_ACCESS_TYPE is INTEGER ; type TEMP_LIST_NODE is record ITEM : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; START_IN : BOOLEAN := false ; end record ; type TEMP_LIST is array (TEMP_LIST_NODE_ACCESS_TYPE range <>) of TEMP_LIST_NODE ; -- 30 is an maximum estimate for the number of possible -- non_local connections and entry_point connections NON_LOCAL_LIST : TEMP_LIST (1..30) ; LOCAL_ENTRY_LIST : TEMP_LIST (1..30) ; type TRANSLATION_TYPE is (MOVE, RESIZE) ; ERROR_STARTING_TREE_INVALID , ERROR_TRANSLATE_NULL , ERROR_TRANSLATE_ROOT , HANDLE_BEFORE_HILIGHTING_ABORT , HANDLE_BEFORE_TRANSLATING_ABORT , HANDLE_RECOVERY , MOVE_TRANSLATION_ERROR , RESIZE_TRANSLATION_ERROR : EXCEPTION ; function INVERSE ( TRANSLATE_OPERATION : in TRANSLATION_TYPE ; TRANSLATION_FACTOR : in FLOAT ) return FLOAT is -- This function inverts the translation factor in -- the appropriate fashion depending on if this -- is being done for a Move or Resize. begin if TRANSLATE_OPERATION = RESIZE then return 1.0 / TRANSLATION_FACTOR ; else return - TRANSLATION_FACTOR ; end if ; end INVERSE ; procedure TRANSLATE_GRAPH_NODE ( TRANSLATE_OPERATION : in TRANSLATION_TYPE ; GRAPH_PTR : in TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; X_TRANSLATION : in FLOAT ; Y_TRANSLATION : in FLOAT ; A_LINE_POINT : in BOOLEAN := false ) is -- This procedure translates the GKS point values found in -- the specified graph node. DELTA_X : INTEGER ; DELTA_Y : INTEGER ; ENTRY_DELTA_X : INTEGER ; ENTRY_DELTA_Y : INTEGER ; NODE_TYPE : TREE_DATA.ENTITY_TYPE ; ENTRY_PT_ENTITY : TREE_DATA.ENTRY_LIST_TYPE ; ENTRY_PT_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; ENTRY_PT_GPTR : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; begin if GRAPH_PTR /= NULL_POINTER then if TRANSLATE_OPERATION = RESIZE then -- save the old location point to use in computing the -- amount it has been moved (DELTA). DELTA_X := GRAPH( GRAPH_PTR ).DATA.LOCATION.X ; DELTA_Y := GRAPH( GRAPH_PTR ).DATA.LOCATION.Y ; -- if the point is a label then resize .location.x with -- respect to the parent right side line by using offset -- constants, and then just move the .size -- point without resizing it NODE_TYPE := TREE( GRAPH( GRAPH_PTR ).OWNING_TREE_NODE ).NODE_TYPE ; -- an entry point is handled by the task which contains it if NODE_TYPE = TYPE_ENTRY_POINT then null ; elsif (not A_LINE_POINT) and then ( NODE_TYPE in IMPORTED_VIRTUAL_PACKAGE .. EXPORTED_EXCEPTION ) then -- translate the location point GRAPH( GRAPH_PTR ).DATA.LOCATION.X := INTEGER ( FLOAT ( ( GRAPH( GRAPH_PTR ).DATA.LOCATION.X + IMPORT_EXPORT_X_OFFSET ) - BASE_POINT.X ) * X_TRANSLATION ) + BASE_POINT.X - IMPORT_EXPORT_X_OFFSET ; GRAPH( GRAPH_PTR ).DATA.LOCATION.Y := INTEGER ( FLOAT ( GRAPH( GRAPH_PTR ).DATA.LOCATION.Y - BASE_POINT.Y ) * Y_TRANSLATION ) + BASE_POINT.Y ; -- compute the amount the location point was moved DELTA_X := GRAPH( GRAPH_PTR ).DATA.LOCATION.X - DELTA_X ; DELTA_Y := GRAPH( GRAPH_PTR ).DATA.LOCATION.Y - DELTA_Y ; GRAPH( GRAPH_PTR ).DATA.SIZE.X := GRAPH( GRAPH_PTR ).DATA.SIZE.X + DELTA_X ; GRAPH( GRAPH_PTR ).DATA.SIZE.Y := GRAPH( GRAPH_PTR ).DATA.SIZE.Y + DELTA_Y ; else -- resizing something other than a label -- translate the location point GRAPH( GRAPH_PTR ).DATA.LOCATION.X := INTEGER ( FLOAT ( GRAPH( GRAPH_PTR ).DATA.LOCATION.X - BASE_POINT.X ) * X_TRANSLATION ) + BASE_POINT.X ; GRAPH( GRAPH_PTR ).DATA.LOCATION.Y := INTEGER ( FLOAT ( GRAPH( GRAPH_PTR ).DATA.LOCATION.Y - BASE_POINT.Y ) * Y_TRANSLATION ) + BASE_POINT.Y ; -- translate the size point if it is in use if GRAPH( GRAPH_PTR ).DATA.SIZE /= NULL_POINT then GRAPH( GRAPH_PTR ).DATA.SIZE.X := INTEGER ( FLOAT ( GRAPH( GRAPH_PTR ).DATA.SIZE.X - BASE_POINT.X ) * X_TRANSLATION ) + BASE_POINT.X ; GRAPH( GRAPH_PTR ).DATA.SIZE.Y := INTEGER ( FLOAT ( GRAPH( GRAPH_PTR ).DATA.SIZE.Y - BASE_POINT.Y ) * Y_TRANSLATION ) + BASE_POINT.Y ; end if ; -- If current node is a task node then resize -- the task entry points associated with the task if NODE_TYPE = TYPE_TASK then ENTRY_PT_ENTITY := TREE( GRAPH( GRAPH_PTR ).OWNING_TREE_NODE ).ENTRY_LIST ; while ENTRY_PT_ENTITY /= TREE_DATA.NULL_POINTER loop ENTRY_PT_NODE := LIST( ENTRY_PT_ENTITY ).ITEM ; ENTRY_PT_GPTR := TREE( ENTRY_PT_NODE ).GRAPH_DATA ; ENTRY_DELTA_Y := GRAPH( ENTRY_PT_GPTR ).DATA.LOCATION.Y ; -- set the location y GRAPH( ENTRY_PT_GPTR ).DATA.LOCATION.Y := INTEGER ( FLOAT ( GRAPH( ENTRY_PT_GPTR ).DATA.LOCATION.Y - BASE_POINT.Y ) * Y_TRANSLATION ) + BASE_POINT.Y ; -- compute the amount the location point was moved ENTRY_DELTA_Y := GRAPH( ENTRY_PT_GPTR ).DATA.LOCATION.Y - ENTRY_DELTA_Y ; -- set the size y GRAPH( ENTRY_PT_GPTR ).DATA.SIZE.Y := GRAPH( ENTRY_PT_GPTR ).DATA.SIZE.Y + ENTRY_DELTA_Y ; -- get the old location x ENTRY_DELTA_X := GRAPH(ENTRY_PT_GPTR).DATA.LOCATION.X ; -- set the new location x GRAPH( ENTRY_PT_GPTR ).DATA.LOCATION.X := GRAPHIC_DRIVER.PARALLELOGRAM_POINTS ( GRAPH( GRAPH_PTR ).DATA.LOCATION , GRAPH( GRAPH_PTR ).DATA.SIZE , GRAPH( ENTRY_PT_GPTR ).DATA.LOCATION.Y ) - IMPORT_EXPORT_X_OFFSET ; -- compute the amount the location point was moved ENTRY_DELTA_X := GRAPH( ENTRY_PT_GPTR ).DATA.LOCATION.X - ENTRY_DELTA_X ; -- set the size X GRAPH( ENTRY_PT_GPTR ).DATA.SIZE.X := GRAPH( ENTRY_PT_GPTR ).DATA.SIZE.X + ENTRY_DELTA_X ; ENTRY_PT_ENTITY := LIST( ENTRY_PT_ENTITY ).NEXT ; end loop ; end if ; end if ; else -- MOVE -- if the the point is a line and the translation -- results in a beyond limit move, CONSTRAINT_ERROR -- will be raised. TRANSLATE_TREE will then set -- the point to the wc limit. This is temporary -- since the line should be redrawn by the user anyway. -- translate the location point GRAPH( GRAPH_PTR ).DATA.LOCATION.X := GRAPH( GRAPH_PTR ).DATA.LOCATION.X - INTEGER( X_TRANSLATION ) ; GRAPH( GRAPH_PTR ).DATA.LOCATION.Y := GRAPH( GRAPH_PTR ).DATA.LOCATION.Y - INTEGER( Y_TRANSLATION ) ; -- translate the size point if it is in use if GRAPH( GRAPH_PTR ).DATA.SIZE /= NULL_POINT then GRAPH( GRAPH_PTR ).DATA.SIZE.X := GRAPH( GRAPH_PTR ).DATA.SIZE.X - INTEGER( X_TRANSLATION ) ; GRAPH( GRAPH_PTR ).DATA.SIZE.Y := GRAPH( GRAPH_PTR ).DATA.SIZE.Y - INTEGER( Y_TRANSLATION ) ; end if ; end if ; --TRANSLATION_TYPE end if ; end TRANSLATE_GRAPH_NODE ; procedure TRANSLATE_TREE ( TRANSLATE_OPERATION : in TRANSLATION_TYPE ; PARENT : in TREE_NODE_ACCESS_TYPE ; X_TRANSLATION : in FLOAT ; Y_TRANSLATION : in FLOAT ) is -- Translate the subtree defined by the specified parent -- using the X and Y translation values given. GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; TRANSLATION_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; WALK_STATE : TREE_OPS.WALK_STATE_TYPE ; SAVED_POINT : GRAPHICS_DATA.POINT ; begin START_TREE_WALK ( PARENT, WALK_STATE ) ; loop -- walk the tree until all nodes have been processed TREE_OPS.TREE_WALK ( WALK_STATE, TRANSLATION_NODE ) ; exit when TRANSLATION_NODE = NULL_POINTER ; -- translate the basic points of the associate graph node TRANSLATE_GRAPH_NODE ( TRANSLATE_OPERATION , TREE( TRANSLATION_NODE ).GRAPH_DATA , X_TRANSLATION , Y_TRANSLATION ) ; -- if a connection exists, then translate the connection points if TREE( TRANSLATION_NODE ).NODE_TYPE in EXPORTED_PROCEDURE .. CONNECTION_FOR_DATA then for I in 1 .. MAXIMUM_NO_LINE_SEGMENTS loop begin GRAPH_NODE := TREE( TRANSLATION_NODE ).LINE(I) ; if GRAPH_NODE = NULL_POINTER then exit ; else --[what if doing inverse, and point is null] SAVED_POINT := GRAPH( GRAPH_NODE ).DATA.LOCATION ; TRANSLATE_GRAPH_NODE ( TRANSLATE_OPERATION , GRAPH_NODE , X_TRANSLATION , Y_TRANSLATION , true ) ; end if ; exception -- handle possible moved points outside world coordinates -- since the line must be redrawn by the user, recover -- by storing the saved LOCATION into the SIZE point -- and flagging the LOCATION with the null point when CONSTRAINT_ERROR => GRAPH( GRAPH_NODE ).DATA.SIZE := SAVED_POINT ; GRAPH( GRAPH_NODE ).DATA.LOCATION := NULL_POINT ; when others => -- propogate unknown error raise ; end ; end loop ; -- when resizing export labels with lines, just reset the -- first line point to the size point of the export if TRANSLATE_OPERATION = RESIZE and then TREE( TRANSLATION_NODE ).NODE_TYPE in EXPORTED_PROCEDURE .. EXPORTED_EXCEPTION and then TREE( TRANSLATION_NODE ).LINE(1) /= NULL_POINTER then GRAPH( TREE( TRANSLATION_NODE ).LINE(1) ).DATA.LOCATION := GRAPH( TREE( TRANSLATION_NODE ).GRAPH_DATA ).DATA.SIZE ; end if ; end if ; end loop ; end TRANSLATE_TREE ; function IN_THIS_SUBTREE ( SUBTREE, NODE_IN_QUESTION : TREE_DATA.TREE_NODE_ACCESS_TYPE ) return BOOLEAN is -- This function returns true if the NODE_IN_QUESTION is in the -- subtree defined by the parent node SUBTREE. PTR : TREE_DATA.TREE_NODE_ACCESS_TYPE := NODE_IN_QUESTION ; begin while PTR /= NULL_POINTER loop if PTR = SUBTREE then return true ; else PTR := TREE( PTR ).PARENT ; end if ; end loop ; return false ; end IN_THIS_SUBTREE ; procedure RESTORE_ERASED_CONNECTIONS_TO ( NODE_PTR : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) is -- This procedure will restore any connections to -- the current node which were erased by the call -- to PERFORM_GRAPH_TREE_OP. PTR : TREE_DATA.TREE_NODE_ACCESS_TYPE := NODE_PTR ; REFERING_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; MEMBER_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; NODE_TYPE : TREE_DATA.ENTITY_TYPE := UNUSED ; begin -- check for a valid NODE_PTR and get the node type if PTR /= NULL_POINTER then NODE_TYPE := TREE( PTR ).NODE_TYPE ; end if ; -- process each node with a possible erase connection if NODE_TYPE in EXPORTED_PROCEDURE .. EXPORTED_EXCEPTION then -- check the membership list for connections to the node MEMBER_PTR := TREE( PTR ).MEMBERSHIP ; while MEMBER_PTR /= NULL_POINTER loop -- ignore the parent back pointer - anything else -- is an erased connection REFERING_NODE := LIST( MEMBER_PTR ).ITEM ; if REFERING_NODE /= TREE( PTR ).PARENT then case NODE_TYPE is when EXPORTED_ENTRY_POINT => -- check for continuing back references RESTORE_ERASED_CONNECTIONS_TO ( REFERING_NODE ) ; when others => null ; end case ; -- restore the erased connection by redrawing it DRAW_GRAPH_TREE ( REFERING_NODE, TRUE ) ; end if ; MEMBER_PTR := LIST( MEMBER_PTR ).NEXT ; end loop ; end if ; exception when others => -- handle error conditions that might occur -- recover tree if possible DISPLAY_ERROR (" PROGRAM ERROR -- in MOVE_AND_RESIZE restore lines operations ") ; raise HANDLE_RECOVERY ; end RESTORE_ERASED_CONNECTIONS_TO ; procedure FIND_NON_LOCAL_CONNECTIONS ( TRANSLATION_OPERATION : in TRANSLATION_TYPE ; SUBTREE_PARENT : in TREE_NODE_ACCESS_TYPE ) is -- Initial determination of non-local connections. -- Non-local connections are those connections which span -- the boundary between the subtree and the remainder of -- the tree. END_IN_SUBTREE : BOOLEAN ; START_IN_SUBTREE : BOOLEAN ; TREE_PTR : TREE_DATA.TREE_NODE_ACCESS_TYPE ; CONNECTEE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; WALK_STATE : TREE_OPS.WALK_STATE_TYPE ; ENTRY_COUNT : TEMP_LIST_NODE_ACCESS_TYPE := 0; NON_LOCAL_COUNT : TEMP_LIST_NODE_ACCESS_TYPE := 0; begin -- Process all the connections in the tree by walking the -- entire tree. START_TREE_WALK ( ROOT_NODE, WALK_STATE ) ; loop TREE_WALK ( WALK_STATE, TREE_PTR ) ; exit when TREE_PTR = NULL_POINTER ; -- Check if the current node type contains a connection -- which is in use. if TREE( TREE_PTR ).NODE_TYPE in EXPORTED_PROCEDURE .. CONNECTION_FOR_DATA and then TREE( TREE_PTR ).CONNECTEE /= NULL_POINTER then CONNECTEE_NODE := TREE( TREE_PTR ).CONNECTEE ; -- Determine if the connection starts and/or ends within -- the specified subtree. START_IN_SUBTREE := IN_THIS_SUBTREE ( SUBTREE_PARENT, TREE_PTR ) ; END_IN_SUBTREE := IN_THIS_SUBTREE ( SUBTREE_PARENT, CONNECTEE_NODE ) ; if START_IN_SUBTREE xor END_IN_SUBTREE then -- set up temporary list of tree nodes NON_LOCAL_COUNT := NON_LOCAL_COUNT + 1 ; NON_LOCAL_LIST(NON_LOCAL_COUNT).ITEM := TREE_PTR ; NON_LOCAL_LIST(NON_LOCAL_COUNT).START_IN := START_IN_SUBTREE ; else -- not a non local connection, handle task entry special if TREE( CONNECTEE_NODE ).NODE_TYPE = TYPE_ENTRY_POINT then -- add to list for special last line point position -- due to the parallelogram shape of the task -- set up temporary list of tree nodes ENTRY_COUNT := ENTRY_COUNT + 1 ; LOCAL_ENTRY_LIST(ENTRY_COUNT).ITEM := TREE_PTR ; end if ; end if ; end if ; end loop ; exception when others => -- handle error conditions that might occur -- recover tree if possible DISPLAY_ERROR (" PROGRAM ERROR -- in MOVE_AND_RESIZE find lines operations ") ; raise HANDLE_RECOVERY ; end FIND_NON_LOCAL_CONNECTIONS ; procedure TRANSLATE_NON_LOCAL_CONNECTIONS ( TRANSLATION_OPERATION : in TRANSLATION_TYPE ; SUBTREE_PARENT : in TREE_NODE_ACCESS_TYPE ) is -- Intermediate processing of non-local connections. The -- connections are not redrawn, the appropriate points are -- just translated. -- Non-local connections are those connections which span -- the boundary between the subtree and the remainder of -- the tree. END_IN_SUBTREE : BOOLEAN ; START_IN_SUBTREE : BOOLEAN ; LAST : INTEGER ; TREE_PTR : TREE_DATA.TREE_NODE_ACCESS_TYPE ; CONNECTEE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; WALK_STATE : TREE_OPS.WALK_STATE_TYPE ; X_TRANSLATION : FLOAT ; Y_TRANSLATION : FLOAT ; begin if TRANSLATION_OPERATION = MOVE then X_TRANSLATION := MOVE_X_TRANSLATION ; Y_TRANSLATION := MOVE_Y_TRANSLATION ; else -- RESIZE X_TRANSLATION := RESIZE_X_TRANSLATION ; Y_TRANSLATION := RESIZE_Y_TRANSLATION ; end if ; -- Process all the non local connections using the predetermined lists for J in NON_LOCAL_LIST'range loop TREE_PTR := NON_LOCAL_LIST(J).ITEM ; exit when TREE_PTR = NULL_POINTER ; CONNECTEE_NODE := TREE( TREE_PTR ).CONNECTEE ; -- Find the last point in the connection. for I in 2 .. MAXIMUM_NO_LINE_SEGMENTS loop if TREE( TREE_PTR ).LINE(I) = NULL_POINTER then exit ; else LAST := I ; end if ; end loop ; -- If the connection ends in the moved subtree, then -- translate the end point to the correct new location. -- If connecting to a task entry, just set to .loc. if not NON_LOCAL_LIST(J).START_IN then if TREE( CONNECTEE_NODE ).NODE_TYPE = TYPE_ENTRY_POINT then GRAPH( TREE( TREE_PTR ).LINE(LAST) ).DATA.LOCATION := GRAPH(TREE(CONNECTEE_NODE).GRAPH_DATA).DATA.LOCATION ; else TRANSLATE_GRAPH_NODE ( TRANSLATION_OPERATION , TREE( TREE_PTR ).LINE(LAST) , X_TRANSLATION , Y_TRANSLATION , true ) ; end if ; else for I in 2 .. LAST loop -- The connection starts in the subtree, and -- the points have been translated. Thus it -- requires un-translation. if GRAPH( TREE( TREE_PTR ).LINE(I) ).DATA.LOCATION = NULL_POINT then -- occurs if the original translation would have -- forced the point outside world coordinates -- recover by assigning the previous location -- from the size point GRAPH( TREE( TREE_PTR ).LINE(I) ).DATA.LOCATION := GRAPH( TREE( TREE_PTR ).LINE(I) ).DATA.SIZE ; else TRANSLATE_GRAPH_NODE( TRANSLATION_OPERATION , TREE(TREE_PTR).LINE(I) , INVERSE(TRANSLATION_OPERATION, X_TRANSLATION ) , INVERSE(TRANSLATION_OPERATION, Y_TRANSLATION ) , true ) ; end if ; end loop ; end if ; end loop ; -- Process all the entry connections using the predetermined lists for J in LOCAL_ENTRY_LIST'range loop TREE_PTR := LOCAL_ENTRY_LIST(J).ITEM ; exit when TREE_PTR = NULL_POINTER ; CONNECTEE_NODE := TREE( TREE_PTR ).CONNECTEE ; -- not a non local connection, handle task entry special -- Find the last point in the connection. for I in 2 .. MAXIMUM_NO_LINE_SEGMENTS loop if TREE( TREE_PTR ).LINE(I) = NULL_POINTER then exit ; else LAST := I ; end if ; end loop ; GRAPH( TREE( TREE_PTR ).LINE(LAST) ).DATA.LOCATION := GRAPH(TREE(CONNECTEE_NODE).GRAPH_DATA).DATA.LOCATION ; end loop ; exception when others => -- handle error conditions that might occur -- recover tree if possible DISPLAY_ERROR (" PROGRAM ERROR -- in MOVE_AND_RESIZE translate lines operations ") ; raise HANDLE_RECOVERY ; end TRANSLATE_NON_LOCAL_CONNECTIONS ; procedure VERIFY_NON_LOCAL_CONNECTIONS ( SUBTREE_PARENT : in TREE_NODE_ACCESS_TYPE ) is -- ONLY CALLED AFTER AN OUT-OF-SCOPE MOVE -- Validation of non-local connections. The connections -- are not redrawn, just checked for valid scoping -- Non-local connections are those connections which span -- the boundary between the subtree and the remainder of -- the tree. TREE_PTR : TREE_DATA.TREE_NODE_ACCESS_TYPE ; CONNECTEE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; CONNECTEE_NODE_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE ; WALK_STATE : TREE_OPS.WALK_STATE_TYPE ; TRACE_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; L_C_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; begin -- Process all the non local connections using the predetermined lists for J in NON_LOCAL_LIST'range loop TREE_PTR := NON_LOCAL_LIST(J).ITEM ; exit when TREE_PTR = NULL_POINTER ; CONNECTEE_NODE := TREE( TREE_PTR ).CONNECTEE ; case TREE( TREE_PTR ).NODE_TYPE is -- if an export, then must be invalid on oos move when EXPORTED_PROCEDURE .. EXPORTED_EXCEPTION => DISPLAY_ERROR (" the move will invalidate the exports connection ") ; raise HANDLE_RECOVERY ; when CONNECTION_BY_CALL => L_C_PARENT := LOWEST_COMMON_PARENT (TREE_PTR, CONNECTEE_NODE ) ; CONNECTEE_NODE_PARENT := TREE(CONNECTEE_NODE).PARENT ; case TREE( CONNECTEE_NODE ).NODE_TYPE is when TYPE_PROCEDURE | TYPE_FUNCTION => -- l_c_parent is up one scope if (L_C_PARENT /= CONNECTEE_NODE_PARENT) then DISPLAY_ERROR (" the move will invalidate the subprogram call connection ") ; raise HANDLE_RECOVERY ; end if ; when TYPE_ENTRY_POINT | EXPORTED_ENTRY_POINT | EXPORTED_PROCEDURE | EXPORTED_FUNCTION => -- l_c_parent is up two scopes if (L_C_PARENT /= TREE(CONNECTEE_NODE_PARENT).PARENT) then DISPLAY_ERROR (" the move will " & "invalidate the entry point or export call connection ") ; raise HANDLE_RECOVERY ; end if ; when IMPORTED_PROCEDURE | IMPORTED_FUNCTION => -- must be package with the import if (L_C_PARENT /= CONNECTEE_NODE_PARENT) then DISPLAY_ERROR (" the move will invalidate the import call connection ") ; raise HANDLE_RECOVERY ; end if ; when others => -- invalid parent for call DISPLAY_ERROR (" PROGRAM ERROR -- in MOVE_AND_RESIZE verify lines operations " ) ; raise HANDLE_RECOVERY ; end case ; -- callee type when CONNECTION_FOR_DATA => L_C_PARENT := LOWEST_COMMON_PARENT (TREE_PTR, CONNECTEE_NODE ) ; case TREE( CONNECTEE_NODE ).NODE_TYPE is when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE => TRACE_PARENT := TREE_PTR ; while TRACE_PARENT /= ROOT_NODE and TRACE_PARENT /= NULL_POINTER loop if TRACE_PARENT = CONNECTEE_NODE then DISPLAY_ERROR (" the move will " & "invalidate the visibility connection (not needed) ") ; raise HANDLE_RECOVERY ; end if ; TRACE_PARENT := TREE(TRACE_PARENT).PARENT ; end loop ; TRACE_PARENT := TREE(CONNECTEE_NODE).PARENT ; while TRACE_PARENT /= ROOT_NODE and TRACE_PARENT /= NULL_POINTER loop if TRACE_PARENT = TREE(TREE_PTR).PARENT then DISPLAY_ERROR (" the move will " & "invalidate the visibility connection (not needed) ") ; raise HANDLE_RECOVERY ; end if ; TRACE_PARENT := TREE(TRACE_PARENT).PARENT ; end loop ; if L_C_PARENT /= TREE( CONNECTEE_NODE ).PARENT then DISPLAY_ERROR (" the move will " & "invalidate the visibility connection ") ; raise HANDLE_RECOVERY ; end if ; when IMPORTED_VIRTUAL_PACKAGE | IMPORTED_PACKAGE => if L_C_PARENT /= TREE( CONNECTEE_NODE ).PARENT then DISPLAY_ERROR (" the move will invalidate the visibility connection ") ; raise HANDLE_RECOVERY ; end if ; when others => -- invalid parent for visibility connect DISPLAY_ERROR (" PROGRAM ERROR -- in MOVE_AND_RESIZE verify lines operations " ) ; raise HANDLE_RECOVERY ; end case ; -- visibility connectee type when others => -- invalid parent for visibility connect DISPLAY_ERROR (" PROGRAM ERROR -- in MOVE_AND_RESIZE verify lines operations " ) ; raise HANDLE_RECOVERY ; end case ; -- origin of connection type end loop ; end VERIFY_NON_LOCAL_CONNECTIONS ; procedure REDRAW_NON_LOCAL_CONNECTIONS ( SUBTREE_PARENT : in TREE_NODE_ACCESS_TYPE ) is -- Prompt the user to redraw all connections which span -- the boundary between the subtree and the remainder of -- the tree. END_POINT : GRAPHICS_DATA.POINT ; START_POINT : GRAPHICS_DATA.POINT ; LAST : INTEGER ; NEW_CONNECTION : TREE_DATA.LINE_TYPE ; TREE_PTR : TREE_DATA.TREE_NODE_ACCESS_TYPE ; WALK_STATE : TREE_OPS.WALK_STATE_TYPE ; STATUS : COMMAND_TYPE ; begin -- Process all the non local connections using the predetermined lists for J in NON_LOCAL_LIST'range loop TREE_PTR := NON_LOCAL_LIST(J).ITEM ; exit when TREE_PTR = NULL_POINTER ; START_POINT := GRAPH( TREE( TREE_PTR ).LINE(1) ).DATA.LOCATION ; -- Find the last point in the connection. for I in 2 .. MAXIMUM_NO_LINE_SEGMENTS loop if TREE( TREE_PTR ).LINE(I) = NULL_POINTER then exit ; else LAST := I ; end if ; end loop ; END_POINT := GRAPH( TREE( TREE_PTR ).LINE(LAST) ).DATA.LOCATION ; -- for end in subtree case, -- since just the line was deleted after moving and resizing, -- if it was a line off of a label delete the label, then for -- all lines redraw the line for user to keep or cancel if not NON_LOCAL_LIST(J).START_IN then if TREE( TREE_PTR ).NODE_TYPE in EXPORTED_PROCEDURE .. EXPORTED_EXCEPTION then if TREE(TREE_PTR).NODE_TYPE /= EXPORTED_ENTRY_POINT then PERFORM_SEGMENT_OP( GRAPH (TREE (TREE_PTR).GRAPH_DATA ). DATA.LABEL_SEG_ID , DELETED ) ; else -- an exported_entry_point -- restore any chained exported entry points RESTORE_ERASED_CONNECTIONS_TO (TREE_PTR) ; end if ; end if ; DRAW_GRAPH_TREE( TREE_PTR, true ) ; end if ; -- highlight the new connection PERFORM_LINE_OP ( TREE_PTR, HILITED ) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " CANCEL to delete and redesign line, CONFIRM to maintain hilighted line " , VIRTUAL_TERMINAL_INTERFACE.CENTER_A_LINE , ROW_NO( 23 ) ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; -- request user confirm of deletion STATUS := CONTROL_DELETE_MENU ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; -- process the results of the confirmation if STATUS = CANCEL_CMD then -- Erase the old connection and redraw the label. PERFORM_GRAPH_TREE_OP ( TREE_PTR, RESTORED ) ; PERFORM_LINE_OP ( TREE_PTR, DELETED ) ; for I in 1 .. LAST loop -- release each graph node and remove reference to it. TREE_OPS.RELEASE_GRAPH_NODE ( TREE( TREE_PTR ).LINE(I) ) ; TREE( TREE_PTR ).LINE(I) := NULL_POINTER ; end loop ; -- Create the connection start and end point markers REFERENCE_MARKER ( GKS_SPECIFICATION.VISIBLE , START_POINT ) ; REFERENCE_MARKER ( GKS_SPECIFICATION.VISIBLE , END_POINT ) ; -- Obtain the new connection. NEW_CONNECTION := NULL_LINE ; REQUEST_CONNECTION ( TREE_PTR , START_POINT , END_POINT , NEW_CONNECTION ) ; -- Delete the connection start and end point markers. REFERENCE_MARKER ( GKS_SPECIFICATION.INVISIBLE , START_POINT ) ; REFERENCE_MARKER ( GKS_SPECIFICATION.INVISIBLE , END_POINT ) ; -- Replace the old connection, and update the tree -- with the new connection. TREE( TREE_PTR ).LINE := NEW_CONNECTION ; -- place the line marking symbol if necessary LABEL_CALL_MARKING (TREE_PTR) ; else -- they want to keep the translated line -- unhilight PERFORM_LINE_OP ( TREE_PTR, RESTORED ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; end if ; end loop ; exception when OPERATION_ABORTED_BY_OPERATOR => -- abort during connection, delete the connection start -- and end point markers REFERENCE_MARKER ( GKS_SPECIFICATION.INVISIBLE , START_POINT ) ; REFERENCE_MARKER ( GKS_SPECIFICATION.INVISIBLE , END_POINT ) ; raise HANDLE_RECOVERY ; when others => -- handle error conditions that might occur -- recover tree if possible DISPLAY_ERROR (" PROGRAM ERROR -- in MOVE_AND_RESIZE redraw lines operations ") ; raise HANDLE_RECOVERY ; end REDRAW_NON_LOCAL_CONNECTIONS ; -- MOVE_AND_RESIZE begin if not CHECK_IF_ANNOTATED_TREE_VALID then DISPLAY_ERROR (" overlapping of entities prevents this scope from being translated") ; raise ERROR_STARTING_TREE_INVALID ; end if; -- save the tree UTIL_FOR_TREE.ARCHIVE_THE_TREE ; -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; SCOPE_SELECTION_LOOP: loop begin -- set up for aborting SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- request the user identify the scope to be translated REQUEST_POINT (" select point identifying scope to be translated", REFERENCE_POINT , PARENT ) ; -- set up for aborting SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; if TREE( PARENT ).NODE_TYPE = TYPE_ENTRY_POINT or else TREE( PARENT ).NODE_TYPE in IMPORTED_VIRTUAL_PACKAGE .. EXPORTED_EXCEPTION then LABEL_ONLY := true ; if TREE( PARENT ).NODE_TYPE in IMPORTED_VIRTUAL_PACKAGE .. IMPORTED_FUNCTION then IMPORT_LABEL := true ; end if ; end if ; -- get the graph pointer GPTR := TREE( PARENT ).GRAPH_DATA ; -- check for a valid parent if PARENT = ROOT_NODE then DISPLAY_ERROR (" invalid, the outer scope cannot be moved ") ; raise ERROR_TRANSLATE_ROOT ; elsif PARENT = NULL_POINTER then DISPLAY_ERROR (" PROGRAM ERROR -- request point returned null parent ") ; raise ERROR_TRANSLATE_NULL ; else -- predetermine the non local connections and entry connections FIND_NON_LOCAL_CONNECTIONS( MOVE, PARENT ) ; exit SCOPE_SELECTION_LOOP ; end if ; exception when ERROR_TRANSLATE_ROOT => -- User already notified of the error. null ; when OPERATION_ABORTED_BY_OPERATOR | ERROR_TRANSLATE_NULL => -- the operator wants to abort raise HANDLE_BEFORE_HILIGHTING_ABORT ; when others => -- handle error conditions that might occur -- recover tree if possible DISPLAY_ERROR (" PROGRAM ERROR -- in MOVE_AND_RESIZE scoping operations ") ; raise HANDLE_RECOVERY ; end ; end loop SCOPE_SELECTION_LOOP ; -- assure that the entire subtree is within the view window VIEW_WINDOW_CHECK( PARENT ) ; -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; -- highlight what is to be moved PERFORM_GRAPH_TREE_OP ( PARENT, HILITED ) ; MOVE_LOOP: loop begin -- MOVE -- request new location point for parent -- set up for aborting SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; if LABEL_ONLY then -- place cursor at .location for imports, -- location.x, .size.y for exports if IMPORT_LABEL then MOVE_REFERENCE_POINT := GRAPH( GPTR ).DATA.LOCATION ; else MOVE_REFERENCE_POINT := (X => GRAPH( GPTR ).DATA.SIZE.X , Y => GRAPH( GPTR ).DATA.LOCATION.Y ); end if ; REQUEST_POINT (" select new location for annotation, within scope", MOVE_REFERENCE_POINT , NEW_PARENT , true ) ; else -- place cursor at .location MOVE_REFERENCE_POINT := GRAPH( GPTR ).DATA.LOCATION ; REQUEST_POINT (" select new location ( upper left ) point ", MOVE_REFERENCE_POINT , NEW_PARENT , true ) ; end if ; -- set up for aborting SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- Determine if new location is valid. Do this by checking -- to see if NEW_PARENT is the parent of the subtree to -- be moved, or if it is within the subtree to be moved. if not ( TREE( PARENT ).PARENT = NEW_PARENT or else PARENT = NEW_PARENT ) then if (NEW_PARENT = ROOT_NODE) or else not ( SCOPE_CHECK( GRAPH( TREE( NEW_PARENT ).GRAPH_DATA ). DATA.LOCATION , PARENT ) ) then -- don't allow oos move into an instantiated unit if TREE( NEW_PARENT ).NODE_TYPE in TYPE_VIRTUAL_PACKAGE .. TYPE_FUNCTION and then TREE( NEW_PARENT ).GENERIC_STATUS = GENERIC_INSTANTIATION then DISPLAY_ERROR (" no entities can be placed inside an instantiated unit ") ; raise MOVE_TRANSLATION_ERROR ; end if ; -- don't allow oos move into an annotation if TREE( NEW_PARENT ).NODE_TYPE in TYPE_ENTRY_POINT .. EXPORTED_EXCEPTION then DISPLAY_ERROR (" no entities can be placed inside an annotation ") ; raise MOVE_TRANSLATION_ERROR ; end if ; -- don't allow oos move of task to the root if NEW_PARENT = ROOT_NODE and then TREE( PARENT ).NODE_TYPE = TYPE_TASK then DISPLAY_ERROR (" invalid, stand alone tasks are not allowed ") ; raise MOVE_TRANSLATION_ERROR ; end if ; -- don't allow oos move of import annotated pkg out of root if NEW_PARENT /= ROOT_NODE and then TREE( PARENT ).NODE_TYPE in TYPE_VIRTUAL_PACKAGE .. TYPE_PACKAGE and then TREE( PARENT ).IMPORTED_LIST /= NULL_POINTER then DISPLAY_ERROR (" invalid, only outer most scope is valid for import declartion ") ; raise MOVE_TRANSLATION_ERROR ; end if ; -- oos - set oos_move to true OOS_MOVE := true ; OOS_PARENT := NEW_PARENT ; end if ; end if ; -- oos - do not allow annotations to be moved out of scope if OOS_MOVE and then (LABEL_ONLY or else TREE( PARENT ).NODE_TYPE = TYPE_BODY) then DISPLAY_ERROR (" an out-of-scope translation of annotations is not permitted ") ; raise MOVE_TRANSLATION_ERROR ; end if ; if not VALID_DRAWING_BOUNDARIES (MOVE_REFERENCE_POINT) then DISPLAY_ERROR (" translation is too close to page boundaries ") ; raise MOVE_TRANSLATION_ERROR ; end if ; MOVE_X_TRANSLATION := FLOAT ( GRAPH( GPTR ).DATA.LOCATION.X - MOVE_REFERENCE_POINT.X ) ; MOVE_Y_TRANSLATION := FLOAT ( GRAPH( GPTR ).DATA.LOCATION.Y - MOVE_REFERENCE_POINT.Y ) ; begin CHECK_POINT.X := GRAPH( GPTR ).DATA.SIZE.X - INTEGER( MOVE_X_TRANSLATION ) ; CHECK_POINT.Y := GRAPH( GPTR ).DATA.SIZE.Y - INTEGER( MOVE_Y_TRANSLATION ) ; exception when CONSTRAINT_ERROR => -- although move and resize could be within world -- coordinates, the first move isn't, easiest to cancel DISPLAY_ERROR (" translation is too close to page boundaries ") ; raise MOVE_TRANSLATION_ERROR ; when others => raise ; end ; if LABEL_ONLY then -- only translate on the y-axis MOVE_X_TRANSLATION := 0.0 ; -- if moving only a task entry point, recompute x move if TREE( PARENT ).NODE_TYPE = TYPE_ENTRY_POINT then PARENT_TASK_GPTR := TREE( TREE( PARENT ).PARENT ).GRAPH_DATA ; -- translate the location point MOVE_REFERENCE_POINT.X := GRAPHIC_DRIVER.PARALLELOGRAM_POINTS ( GRAPH( PARENT_TASK_GPTR ).DATA.LOCATION , GRAPH( PARENT_TASK_GPTR ).DATA.SIZE , MOVE_REFERENCE_POINT.Y ) - IMPORT_EXPORT_X_OFFSET ; MOVE_X_TRANSLATION := FLOAT ( GRAPH( GPTR ).DATA.LOCATION.X - MOVE_REFERENCE_POINT.X ) ; end if ; end if ; TRANSLATE_TREE ( MOVE, PARENT, MOVE_X_TRANSLATION, MOVE_Y_TRANSLATION ) ; TRANSLATE_NON_LOCAL_CONNECTIONS( MOVE, PARENT ) ; exit MOVE_LOOP ; exception when MOVE_TRANSLATION_ERROR => -- User already notified of the error. -- oos - reset oos_move to false OOS_MOVE := false ; OOS_PARENT := NULL_POINTER ; when OPERATION_ABORTED_BY_OPERATOR => -- the operator wants to abort raise HANDLE_BEFORE_TRANSLATING_ABORT ; when others => -- handle error conditions that might occur -- recover tree if possible DISPLAY_ERROR (" PROGRAM ERROR -- in MOVE_AND_RESIZE move operation ") ; raise HANDLE_RECOVERY ; end ; end loop MOVE_LOOP ; if not LABEL_ONLY then -- RESIZE -- check if size point is off screen, if so then zoom out if not LOCATION_IN_GRAPHIC_VIEWPORT( GRAPH( GPTR ).DATA.SIZE ) then -- zoom out GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( ON ) ; GRAPHIC_DRIVER.ZOOM( GRAPHICS_DATA.MAX_ZOOM_OUT ) ; GRAPHIC_DRIVER.PAN_AND_ZOOM_DISPLAY( OFF ) ; -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ) ; end if; -- mark the new .location point REFERENCE_MARKER ( GKS_SPECIFICATION.VISIBLE , MOVE_REFERENCE_POINT ) ; RESIZE_LOOP: loop begin -- set up for aborting SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- set cursor to .size point RESIZE_REFERENCE_POINT := GRAPH( GPTR ).DATA.SIZE ; -- request new size point for parent REQUEST_POINT (" select new size ( lower right ) point ", RESIZE_REFERENCE_POINT, NEW_PARENT , true ) ; -- set up for aborting SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- oos this test is not invalid, the final tree check will catch any errors -- -- Determine if new location is valid. Do this by checking -- -- to see if NEW_PARENT is the parent of the subtree to -- -- be moved, or if it is within the subtree to be moved. -- if not ( TREE( PARENT ).PARENT = NEW_PARENT or else -- PARENT = NEW_PARENT ) then -- if (NEW_PARENT = ROOT_NODE) or else -- not ( SCOPE_CHECK( GRAPH( TREE( NEW_PARENT ).GRAPH_DATA ). -- DATA.LOCATION , PARENT ) ) then -- DISPLAY_ERROR (" an out-of-scope translation is not permitted ") ; -- raise RESIZE_TRANSLATION_ERROR ; -- end if ; -- end if ; if not VALID_DRAWING_BOUNDARIES (RESIZE_REFERENCE_POINT) then DISPLAY_ERROR (" translation is to close to page boundaries, retry ") ; raise RESIZE_TRANSLATION_ERROR ; end if ; -- translate the subtree BASE_POINT := GRAPH( GPTR ).DATA.LOCATION ; OLD_SIZE_POINT := GRAPH( GPTR ).DATA.SIZE ; if not ( RESIZE_REFERENCE_POINT.X > BASE_POINT.X and RESIZE_REFERENCE_POINT.Y < BASE_POINT.Y ) then DISPLAY_ERROR (" invalid sizing point selected, retry ") ; raise RESIZE_TRANSLATION_ERROR ; end if ; RESIZE_X_TRANSLATION := FLOAT ( RESIZE_REFERENCE_POINT.X - BASE_POINT.X ) / FLOAT ( OLD_SIZE_POINT.X - BASE_POINT.X ) ; RESIZE_Y_TRANSLATION := FLOAT ( RESIZE_REFERENCE_POINT.Y - BASE_POINT.Y ) / FLOAT ( OLD_SIZE_POINT.Y - BASE_POINT.Y ) ; TRANSLATE_TREE ( RESIZE, PARENT, RESIZE_X_TRANSLATION, RESIZE_Y_TRANSLATION ) ; TRANSLATE_NON_LOCAL_CONNECTIONS( RESIZE, PARENT ) ; -- turn off reference mark REFERENCE_MARKER ( GKS_SPECIFICATION.INVISIBLE , MOVE_REFERENCE_POINT ) ; exit RESIZE_LOOP ; exception when RESIZE_TRANSLATION_ERROR => -- User already notified of the error. null ; when OPERATION_ABORTED_BY_OPERATOR => -- the operator wants to abort -- turn off reference mark REFERENCE_MARKER ( GKS_SPECIFICATION.INVISIBLE , MOVE_REFERENCE_POINT ) ; raise HANDLE_RECOVERY ; when others => -- handle error conditions that might occur -- recover tree if possible -- turn off reference mark REFERENCE_MARKER ( GKS_SPECIFICATION.INVISIBLE , MOVE_REFERENCE_POINT ) ; DISPLAY_ERROR (" PROGRAM ERROR -- in MOVE_AND_RESIZE resize operation ") ; raise HANDLE_RECOVERY ; end ; end loop RESIZE_LOOP ; -- oos relationship altering if OOS_MOVE then -- modify old parent OLD_SCOPE_PARENT := TREE( PARENT ).PARENT ; TEMP_LIST_HEAD_PTR := GET_LIST_HEAD ( OLD_SCOPE_PARENT, CONTAINED_LIST ) ; TEMP_LIST_PTR := FIND_NODE_REFERENCE( TEMP_LIST_HEAD_PTR, PARENT ) ; -- remove contained list reference, and membership reference REMOVE_NODE_FROM_LIST( OLD_SCOPE_PARENT, CONTAINED_LIST, TEMP_LIST_PTR ) ; -- modify oos parent contained list, and current node membership SET_PARENT( PARENT, OOS_PARENT, CONTAINED_LIST ) ; -- verify connects VERIFY_NON_LOCAL_CONNECTIONS ( PARENT ) ; end if ; -- oos_move end if ; -- label_only -- determine if the translated tree is valid MOVE_OK := CHECK_IF_ANNOTATED_TREE_VALID ; if MOVE_OK then -- delete the old tree and redraw it as translated PERFORM_GRAPH_TREE_OP ( PARENT, DELETED ) ; DRAW_GRAPH_TREE ( PARENT , TRUE ) ; REDRAW_NON_LOCAL_CONNECTIONS ( PARENT ) ; else -- the move would result in an incorrect tree DISPLAY_ERROR(" Move canceled, an invalid graph would have resulted "); raise HANDLE_RECOVERY ; end if ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; exception when HANDLE_RECOVERY => -- turn off abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- display recovery message VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " restoring the graph to it's status prior to this attempted move operation " , VIRTUAL_TERMINAL_INTERFACE.CENTER_A_LINE , ROW_NO( 23 ) ) ; -- recover the tree UTIL_FOR_TREE.RECOVER_THE_TREE ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set the menu as current window GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; when FIGURE_TOO_NARROW => -- turn off abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- the move would result in an incorrect tree DISPLAY_ERROR(" Move canceled, an invalid graph (figure to narrow) would have resulted "); -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- display recovery message VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " restoring the graph to it's status prior to this attempted move operation " , VIRTUAL_TERMINAL_INTERFACE.CENTER_A_LINE , ROW_NO( 23 ) ) ; -- recover the tree UTIL_FOR_TREE.RECOVER_THE_TREE ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set the menu as current window GRAPHIC_DRIVER.SELECT_WINDOW ( GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; when ERROR_STARTING_TREE_INVALID | HANDLE_BEFORE_HILIGHTING_ABORT => -- turn off abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set the menu as current window GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; when HANDLE_BEFORE_TRANSLATING_ABORT => -- User already notified of the error. -- set menu window active PERFORM_GRAPH_TREE_OP ( PARENT, RESTORED ) ; -- turn off abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set the menu as current window GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in MOVE_AND_RESIZE operation ") ; -- turn off abort capability GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- display recovery message VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " restoring the graph to it's status prior to this attempted move operation " , VIRTUAL_TERMINAL_INTERFACE.CENTER_A_LINE , ROW_NO( 23 ) ) ; -- recover the tree UTIL_FOR_TREE.RECOVER_THE_TREE ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW (GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ) ; end MOVE_AND_RESIZE ; end MMI_CONTROL_MENUS ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --mmi_attributes_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-11-14 1610 by JL with MMI_PARAMETERS ; use MMI_PARAMETERS ; package MMI_ATTRIBUTES is -- ============================================================= -- -- This package implements the attribute control capability of -- the Man-Machine Interface. It controls the ATTRIBUTES_MENU -- and all subordinate menus, both in terms of displaying -- the menus and implementing their implied functionality. -- -- ============================================================= procedure CONTROL_ATTRIBUTES_MENU ; -- ========================================================= -- This procedure performs operations required to implement -- the attributes menu commands. -- ========================================================= procedure CREATE_CONNECTION( COMMAND : in COMMAND_TYPE ) ; -- ========================================================= -- This procedure performs operations required to implement -- the creation of a connection based on the command type. -- ========================================================= function CONTROL_ANNOTATING_MENU return COMMAND_TYPE ; -- ========================================================= -- This function performs operations required to implement -- the annotating menu commands. -- ========================================================= end MMI_ATTRIBUTES ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --mmi_attributes_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 23 January 1986 15:18 by JR -- version 86-01-20 1505 by JL with GKS_SPECIFICATION ; with GRAPHICS_DATA ; use GRAPHICS_DATA ; with GRAPHIC_DRIVER ; use GRAPHIC_DRIVER ; with TRACE_PKG ; with TREE_DATA ; with TREE_OPS ; use TREE_OPS ; with MMI_PARAMETERS ; use MMI_PARAMETERS ; with MMI_CONTROL_MENUS ; use MMI_CONTROL_MENUS ; with UTILITIES ; use UTILITIES ; with UTIL_FOR_TREE ; use UTIL_FOR_TREE ; with VIRTUAL_TERMINAL_INTERFACE ; use VIRTUAL_TERMINAL_INTERFACE ; package body MMI_ATTRIBUTES is BLANK_STRING : STRING (1 .. MAXCOL) := ( others => ' ' ) ; ERROR_ON_LINE_TYPE_INPUT : exception ; ERROR_ON_CHANGE_TYPE : exception ; function CONTROL_COLOR_LINE_MENU ( CHANGE_ENTITY : in GRAPHIC_ENTITY ) return COMMAND_TYPE is -- ========================================================= -- This procedure performs operations required to implement -- the color/line menu commands. The returned command -- should always be BACKUP_CMD. -- ========================================================= COMMAND : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DONE : BOOLEAN := FALSE ; CURRENT_COLOR_TYPE : COLOR_TYPE ; CURRENT_LINE_TYPE : LINE_TYPE ; subtype COLOR_TYPE_CMD is COMMAND_TYPE range GREEN_CMD..BLACK_CMD ; subtype LINE_TYPE_CMD is COMMAND_TYPE range SOLID_CMD..DOTTED_CMD ; COMMAND_TO_COLOR_TYPE : constant array ( COLOR_TYPE_CMD ) of COLOR_TYPE := ( GREEN_CMD => GREEN , BLUE_CMD => BLUE , VIOLET_CMD => VIOLET , RED_CMD => RED , ORANGE_CMD => ORANGE , YELLOW_CMD => YELLOW , BLACK_CMD => BLACK ) ; COMMAND_TO_LINE_TYPE : constant array ( LINE_TYPE_CMD ) of LINE_TYPE := ( SOLID_CMD => SOLID , DASHED_CMD => DASHED , DOTTED_CMD => DOTTED ) ; begin -- pre place icon cursor on green_cmd COMMAND := GREEN_CMD ; while not DONE loop begin -- determine current color -- so as to display CURRENT_COLOR_TYPE := ENTITY_COLOR ( CHANGE_ENTITY ) ; CURRENT_LINE_TYPE := ENTITY_LINE ( CHANGE_ENTITY ) ; -- display current color type VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "Current attribute is a " & LINE_TYPE'image( CURRENT_LINE_TYPE ) & " line of color " & COLOR_TYPE'image( CURRENT_COLOR_TYPE ) , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- display the current menu and get command from GRAPHICS_DRIVER DISPLAY_MENU_AND_GET_COMMAND ( MENU_ID'( COLOR_LINE_MENU ) , COMMAND ) ; case COMMAND is -- implement the color menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( COLOR_LINE_MENU ) ) ; when BACKUP_CMD => -- return to the next higher menu DONE := true ; -- exit the loop when RESTART_CMD => -- return to the main menu raise HANDLE_RESTART ; when COLOR_TYPE_CMD => -- set the color for the proper entity ENTITY_COLOR ( CHANGE_ENTITY ) := COMMAND_TO_COLOR_TYPE ( COMMAND ) ; when LINE_TYPE_CMD => -- set the line type for the entity ENTITY_LINE ( CHANGE_ENTITY ) := COMMAND_TO_LINE_TYPE ( COMMAND ) ; when others => -- this should not occur null ; end case ; -- COMMAND -- erase the prompt LOW_LEVEL_OPERATIONS ( LOW_LEVEL_CRT_FUNCTIONS'( ERASE_CURSOR_SCREEN ) ) ; exception when HANDLE_RESTART => -- propogate exception to handle return to main menu GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; raise ; when others => -- handle error conditions that might occur -- report the error and continue UTILITIES.DISPLAY_ERROR ( " PROGRAM ERROR -- in control color/line ") ; end ; end loop ; -- return the command processed return COMMAND ; end CONTROL_COLOR_LINE_MENU ; -- procedure CONTROL_SYMBOL ( COMMAND : in COMMAND_TYPE ) is -- -- ========================================================= -- -- This procedure performs operations required to implement -- -- the changing of symbols. -- -- ========================================================= -- -- SYM_SIZE : NATURAL ; -- NEW_SYM : INDICATOR_LENGTH_4 ; -- CURRENT_SYM : INDICATOR_LENGTH_4 ; -- DONE : BOOLEAN := FALSE ; -- -- SYMBOL_SIZE : constant array -- ( COND_CALL_CMD .. GUARD_ENTRY_CMD ) -- of NATURAL := -- ( COND_CALL_CMD => CONDITIONAL_CALL_SYMBOL'length , -- TIMED_CALL_CMD => TIMED_CALL_SYMBOL'length , -- NORM_REF_CALL_CMD => NORMAL_REFERENCE_SYMBOL'length , -- VIRT_REF_CALL_CMD => VIRTUAL_REFERENCE_SYMBOL'length , -- GUARD_ENTRY_CMD => GUARDED_ENTRY_SYMBOL'length ) ; -- -- begin -- SYM_SIZE := SYMBOL_SIZE( COMMAND ) ; -- while not DONE loop -- begin -- case COMMAND is -- when COND_CALL_CMD => -- CURRENT_SYM(1 .. SYM_SIZE) := CONDITIONAL_CALL_SYMBOL ; -- when TIMED_CALL_CMD => -- CURRENT_SYM(1 .. SYM_SIZE) := TIMED_CALL_SYMBOL ; -- when NORM_REF_CALL_CMD => -- CURRENT_SYM(1 .. SYM_SIZE) := NORMAL_REFERENCE_SYMBOL ; -- when VIRT_REF_CALL_CMD => -- CURRENT_SYM(1 .. SYM_SIZE) := VIRTUAL_REFERENCE_SYMBOL ; -- when GUARD_ENTRY_CMD => -- CURRENT_SYM(1 .. SYM_SIZE) := GUARDED_ENTRY_SYMBOL ; -- when others => -- -- should never occur -- raise ERROR_ON_CHANGE_TYPE ; -- end case ; -- -- -- get new symbol, same length as old -- VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE -- ( "Symbol is '" & CURRENT_SYM(1 .. SYM_SIZE) & -- "', enter new symbol (blank=>no change) of length " & -- INTEGER'image(SYM_SIZE) , -- FORMAT_FCT'( CENTER_A_LINE ) , -- ROW_NO( 23 ) ) ; -- NEW_SYM(1 .. SYM_SIZE) := BLANK_STRING(1 .. SYM_SIZE) ; -- VIRTUAL_TERMINAL_INTERFACE.STRINGIO -- ( NEW_SYM(1 .. SYM_SIZE) , -- CURSOR_ADDRESS'( READ_WITH_ADDRESS ) , -- ROW_NO( 24 ) , -- COL_NO( 1 ) ) ; -- -- -- check for blank entry -- if NEW_SYM(1 .. SYM_SIZE) /= BLANK_STRING(1 .. SYM_SIZE) then -- case COMMAND is -- when COND_CALL_CMD => -- CONDITIONAL_CALL_SYMBOL := NEW_SYM(1 .. SYM_SIZE) ; -- when TIMED_CALL_CMD => -- TIMED_CALL_SYMBOL := NEW_SYM(1 .. SYM_SIZE) ; -- when NORM_REF_CALL_CMD => -- NORMAL_REFERENCE_SYMBOL := NEW_SYM(1 .. SYM_SIZE) ; -- when VIRT_REF_CALL_CMD => -- VIRTUAL_REFERENCE_SYMBOL := NEW_SYM(1 .. SYM_SIZE) ; -- when GUARD_ENTRY_CMD => -- GUARDED_ENTRY_SYMBOL := NEW_SYM(1 .. SYM_SIZE) ; -- when others => -- -- should never occur -- null ; -- end case ; -- COMMAND -- -- end if; -- non-blank -- -- -- a good exit -- DONE := TRUE ; -- -- exception -- when others => -- -- handle error conditions -- -- report the error and continue -- UTILITIES.DISPLAY_ERROR( ERROR_MSG_STRING ) ; -- end ; -- -- end loop ; -- while not DONE -- -- -- erase the prompt and response -- LOW_LEVEL_OPERATIONS -- ( LOW_LEVEL_CRT_FUNCTIONS'( ERASE_CURSOR_SCREEN ) ) ; -- -- end CONTROL_SYMBOL ; procedure CONTROL_ATTRIBUTES_MENU is -- ========================================================= -- This procedure performs operations required to implement -- the attributes menu commands. -- ========================================================= COMMAND, DUMMY : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; CHANGE_ENTITY : GRAPHIC_ENTITY ; DONE : BOOLEAN := FALSE ; COMMAND_TO_GRAPHIC_ENTITY : constant array ( A_VIRT_PACKAGE_CMD .. A_EXPORT_CONNECT_CMD ) of GRAPHIC_ENTITY := ( A_VIRT_PACKAGE_CMD => VIRTUAL_PKG_FIGURE , A_PACKAGE_CMD => PACKAGE_FIGURE , A_SUBPROGRAM_CMD => SUBPROGRAM_FIGURE , A_TASK_CMD => TASK_FIGURE , A_CALL_CONNECT_CMD => CALL_CONNECT_LINE , A_DATA_CONNECT_CMD => DATA_CONNECT_LINE , A_EXPORT_CONNECT_CMD => EXPORT_CONNECT_LINE ) ; begin while not DONE loop begin -- pre place icon cursor on virtual package COMMAND := A_VIRT_PACKAGE_CMD ; -- display the current menu and get command from GRAPHICS_DRIVER DISPLAY_MENU_AND_GET_COMMAND ( MENU_ID'( ATTRIBUTES_MENU ) , COMMAND ) ; case COMMAND is -- implement the attributes menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( ATTRIBUTES_MENU ) ) ; when BACKUP_CMD => -- return to the next higher menu DONE := true ; -- exit the loop when PAN_ZOOM_CMD => -- go to pan/zoom menu, return to here DUMMY := CONTROL_PAN_ZOOM_MENU ; when ATTRIBUTES_MENU_CMD => -- something is to be changed CHANGE_ENTITY := COMMAND_TO_GRAPHIC_ENTITY( COMMAND ) ; DUMMY := CONTROL_COLOR_LINE_MENU( CHANGE_ENTITY ) ; when others => -- this should not occur raise ERROR_ON_CHANGE_TYPE ; end case ; -- COMMAND exception when HANDLE_RESTART => -- propogate exception to handle return to main menu GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; raise ; when others => -- handle error conditions that might occur -- report the error and continue UTILITIES.DISPLAY_ERROR ( " PROGRAM ERROR -- in control attributes ") ; end ; end loop ; -- while not DONE end CONTROL_ATTRIBUTES_MENU ; procedure CREATE_CONNECTION ( COMMAND : in COMMAND_TYPE ) is -- ========================================================= -- This procedure performs operations required to implement -- the create connection. -- ========================================================= use TREE_DATA ; BLANK_LINE : constant String := " " ; CALL_STATUS : COMMAND_TYPE := COMMAND_TYPE'(UNCONDITIONAL_CMD) ; CALL_TYPE : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DATA_TYPE : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; EXPORTS_TYPE : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DUMMY : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; CONNECTION : TREE_DATA.LINE_TYPE ; CONNECT_TYPE : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DONE : Boolean := False ; END_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; END_PARENT_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; END_POINT : GRAPHICS_DATA.POINT ; GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE := NULL_POINTER ; PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; START_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; START_POINT : GRAPHICS_DATA.POINT ; L_C_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; CREATION_ERROR : exception ; CONNECT_ERROR_AFTER_START : exception ; begin case COMMAND is when CALL_CONNECT_CMD | IE_CALL_CONNECT_CMD => -- draw a call connection CALL_STATUS := CONTROL_CALL_STATUS_MENU ; -- restore the menu if COMMAND = CALL_CONNECT_CMD then DISPLAY_MENU( MENU_ID'(DESIGN_MENU), COMMAND ) ; else DISPLAY_MENU( MENU_ID'(ANNOTATING_MENU), COMMAND ) ; end if ; -- set graphics window active. GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get the point where the connection starts REQUEST_POINT ("select starting point within the body of the caller", START_POINT, START_PARENT) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for valid start parent for the connection -- for call connections should be of type_body if START_PARENT = NULL_POINTER or else TREE(START_PARENT).NODE_TYPE /= TYPE_BODY then DISPLAY_ERROR (" invalid scope due to wrong parent type ") ; raise CREATION_ERROR ; end if ; REFERENCE_MARKER (GKS_SPECIFICATION.VISIBLE, START_POINT) ; -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get the point where the connection ends REQUEST_POINT ("select ending point within the scope of the callee", END_POINT , END_PARENT ) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; GRAPH_NODE := TREE( END_PARENT ).GRAPH_DATA ; -- Check the validity of the connection end -- based on the type of the node selected. L_C_PARENT := LOWEST_COMMON_PARENT (START_PARENT, END_PARENT) ; END_PARENT_PARENT := TREE(END_PARENT).PARENT ; case TREE( END_PARENT ).NODE_TYPE is when TYPE_PROCEDURE | TYPE_FUNCTION => if TREE( END_PARENT ).GENERIC_STATUS = GENERIC_DECLARATION then DISPLAY_ERROR ( "invalid, calls cannot be made to a generic declaration" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; if CALL_STATUS = TIMED_CMD then DISPLAY_ERROR ( "invalid, call status cannot be timed" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; -- call must be recursive or l_c_parent is up one scope if (L_C_PARENT /= END_PARENT) and (L_C_PARENT /= END_PARENT_PARENT) then DISPLAY_ERROR ( "invalid, improper visibility for call" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; when TYPE_ENTRY_POINT => -- must be outside the task if (L_C_PARENT /= TREE(END_PARENT_PARENT).PARENT) then DISPLAY_ERROR ( "invalid, calls cannot be made from within the enclosing task " ) ; raise CONNECT_ERROR_AFTER_START ; end if ; END_POINT := GRAPH(GRAPH_NODE).DATA.LOCATION ; when EXPORTED_ENTRY_POINT => if TREE( END_PARENT_PARENT ).GENERIC_STATUS = GENERIC_DECLARATION then DISPLAY_ERROR ( "invalid, calls cannot be made to a generic declaration" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; -- must be outside package with the export if (L_C_PARENT /= TREE(END_PARENT_PARENT).PARENT) then DISPLAY_ERROR ( "invalid, improper visibility for call" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; END_POINT := GRAPH(GRAPH_NODE).DATA.LOCATION ; when IMPORTED_PROCEDURE | IMPORTED_FUNCTION => if CALL_STATUS = TIMED_CMD then DISPLAY_ERROR ( "invalid, call status cannot be timed" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; -- must be package with the import if (L_C_PARENT /= END_PARENT_PARENT) then DISPLAY_ERROR ( "invalid, improper visibility for call" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; END_POINT := GRAPH(GRAPH_NODE).DATA.LOCATION ; when EXPORTED_PROCEDURE | EXPORTED_FUNCTION => if TREE( END_PARENT_PARENT ).GENERIC_STATUS = GENERIC_DECLARATION then DISPLAY_ERROR ( "invalid, calls cannot be made to a generic declaration" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; if CALL_STATUS = TIMED_CMD then DISPLAY_ERROR ( "invalid, call status cannot be timed" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; -- must be outside package with the export if (L_C_PARENT /= TREE(END_PARENT_PARENT).PARENT) then DISPLAY_ERROR ( "invalid, improper visibility for call" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; END_POINT := GRAPH(GRAPH_NODE).DATA.LOCATION ; when others => -- invalid parent to call DISPLAY_ERROR ( "invalid, this type of entity cannot be called " ) ; raise CONNECT_ERROR_AFTER_START ; end case ; REFERENCE_MARKER (GKS_SPECIFICATION.VISIBLE, END_POINT) ; -- Create the tree node, request the connection, -- and then update the TREE node. TREE_NODE := GET_NEW_TREE_NODE (CONNECTION_BY_CALL) ; begin SET_PARENT (TREE_NODE, START_PARENT, CALLEE_LIST) ; if CALL_STATUS = UNCONDITIONAL_CMD then TREE(TREE_NODE).CALL_VARIETY := NORMAL ; elsif CALL_STATUS = TIMED_CMD then TREE(TREE_NODE).CALL_VARIETY := TIMED ; else TREE(TREE_NODE).CALL_VARIETY := CONDITIONAL ; end if ; TREE(TREE_NODE).CONNECTEE := END_PARENT ; -- get the connection REQUEST_CONNECTION (TREE_NODE, START_POINT, END_POINT, CONNECTION) ; TREE(TREE_NODE).LINE := CONNECTION ; MAKE_REFERENCE ( TREE_NODE, END_PARENT ) ; exception when OPERATION_ABORTED_BY_OPERATOR => -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- release the allocated node on error TREE_OPS.RELEASE_TREE_NODE ( TREE_NODE ) ; raise ; -- reference markers turned off later when others => -- release the allocated node on error TREE_OPS.RELEASE_TREE_NODE ( TREE_NODE ) ; -- turn off the markers REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, START_POINT) ; REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, END_POINT) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; raise ; end ; -- turn off the markers REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, START_POINT) ; REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, END_POINT) ; -- draw the call marker if required UTIL_FOR_TREE.LABEL_CALL_MARKING( TREE_NODE ) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when DATA_CONNECT_CMD | IE_DATA_CONNECT_CMD => -- set graphics window active. GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get the point where the connection starts REQUEST_POINT (" select starting point within scope of entity needing package visibility ", START_POINT, START_PARENT) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for valid start parent for the connection -- for data connections should be of -- type_virtual_package .. type_task if START_PARENT = NULL_POINTER or else TREE(START_PARENT).NODE_TYPE not in TYPE_VIRTUAL_PACKAGE .. TYPE_TASK then DISPLAY_ERROR (" invalid scope due to wrong parent type ") ; raise CREATION_ERROR ; end if ; REFERENCE_MARKER (GKS_SPECIFICATION.VISIBLE, START_POINT) ; -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get the point where the connection ends REQUEST_POINT ("select ending point within the (virtual) package scope being reference", END_POINT, END_PARENT) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; GRAPH_NODE := TREE( END_PARENT ).GRAPH_DATA ; -- Check the validity of the connection end -- based on the type of the node selected. L_C_PARENT := LOWEST_COMMON_PARENT (START_PARENT, END_PARENT) ; case TREE( END_PARENT ).NODE_TYPE is when TYPE_VIRTUAL_PACKAGE | TYPE_PACKAGE => PARENT := START_PARENT ; while PARENT /= ROOT_NODE and PARENT /= NULL_POINTER loop if PARENT = END_PARENT then DISPLAY_ERROR ( "invalid, entities are within the same scope" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; PARENT := TREE(PARENT).PARENT ; end loop ; PARENT := TREE(END_PARENT).PARENT ; while PARENT /= ROOT_NODE and PARENT /= NULL_POINTER loop if PARENT = START_PARENT then DISPLAY_ERROR ( "invalid, entities are within the same scope" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; PARENT := TREE(PARENT).PARENT ; end loop ; if L_C_PARENT /= TREE( END_PARENT ).PARENT then DISPLAY_ERROR ( "invalid, improper scoping for connection" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; when IMPORTED_VIRTUAL_PACKAGE | IMPORTED_PACKAGE => if L_C_PARENT /= TREE( END_PARENT ).PARENT then DISPLAY_ERROR ( "invalid, improper scoping for connection" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; -- set the end point to the edge of the -- import label END_POINT := GRAPH(GRAPH_NODE).DATA.LOCATION ; when others => DISPLAY_ERROR ( " invalid, only (virtual) packages or import packages can be referenced " ) ; raise CONNECT_ERROR_AFTER_START ; end case ; -- node type REFERENCE_MARKER (GKS_SPECIFICATION.VISIBLE, END_POINT) ; -- Create and the Tree node, get the connection, -- and then update the TREE node. TREE_NODE := GET_NEW_TREE_NODE (CONNECTION_FOR_DATA) ; begin SET_PARENT (TREE_NODE, START_PARENT, DATA_CONNECT_LIST); TREE(TREE_NODE).CONNECTEE := END_PARENT ; -- get the connection REQUEST_CONNECTION (TREE_NODE, START_POINT, END_POINT, CONNECTION) ; TREE(TREE_NODE).LINE := CONNECTION ; MAKE_REFERENCE(TREE_NODE, END_PARENT) ; exception when OPERATION_ABORTED_BY_OPERATOR => -- release the allocated node on error TREE_OPS.RELEASE_TREE_NODE ( TREE_NODE ) ; raise ; -- reference markers turned off later when others => -- release the allocated node on error TREE_OPS.RELEASE_TREE_NODE ( TREE_NODE ) ; raise ; end ; -- turn off the markers REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, START_POINT) ; REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, END_POINT) ; -- draw the line marker if required UTIL_FOR_TREE.LABEL_CALL_MARKING( TREE_NODE ) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when EXPORT_CONNECT_CMD | IE_EXPORT_CONNECT_CMD => -- draw a exports connection -- set graphics window active. GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get the point where the connection starts REQUEST_POINT ( "select starting export annotation for relationship" , START_POINT , START_PARENT ) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; GRAPH_NODE := TREE(START_PARENT).GRAPH_DATA ; -- check for valid start parent for the connection -- for exports connections should be of -- exported_procedure .. exported_exception if START_PARENT = NULL_POINTER or else TREE(START_PARENT).NODE_TYPE not in EXPORTED_PROCEDURE .. EXPORTED_EXCEPTION then DISPLAY_ERROR ("invalid scope due to wrong parent type ") ; raise CREATION_ERROR ; end if ; if TREE(START_PARENT).CONNECTEE /= NULL_POINTER then DISPLAY_ERROR ("invalid, export is already connected to an entity ") ; raise CREATION_ERROR ; end if ; -- start point at right side of annotation START_POINT := GRAPH( GRAPH_NODE ).DATA.SIZE ; REFERENCE_MARKER( GKS_SPECIFICATION.VISIBLE, START_POINT ) ; -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get the point where the connection ends REQUEST_POINT ("select ending point for relationship", END_POINT, END_PARENT) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; case TREE(END_PARENT).NODE_TYPE is when TYPE_PROCEDURE => if TREE(START_PARENT).NODE_TYPE /= EXPORTED_PROCEDURE then DISPLAY_ERROR ( "invalid, the export annotation does not match to a procedure" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; if TREE( START_PARENT ).PARENT /= TREE( END_PARENT ).PARENT then DISPLAY_ERROR ( "invalid, improper scoping for connection" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; when TYPE_FUNCTION => if TREE(START_PARENT).NODE_TYPE /= EXPORTED_FUNCTION then DISPLAY_ERROR ( "invalid, the export annotation does not match to a function") ; raise CONNECT_ERROR_AFTER_START ; end if ; if TREE( START_PARENT ).PARENT /= TREE( END_PARENT ).PARENT then DISPLAY_ERROR ( "invalid, improper scoping for connection" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; when EXPORTED_PROCEDURE .. EXPORTED_EXCEPTION => GRAPH_NODE := TREE(END_PARENT).GRAPH_DATA ; END_POINT := GRAPH(GRAPH_NODE).DATA.LOCATION ; if TREE(START_PARENT).NODE_TYPE /= TREE(END_PARENT).NODE_TYPE then DISPLAY_ERROR ( "invalid, the export annotation types do not match" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; if TREE( START_PARENT ).PARENT /= TREE( TREE( END_PARENT ).PARENT ).PARENT then DISPLAY_ERROR ( "invalid, improper scoping for connection" ) ; raise CONNECT_ERROR_AFTER_START ; end if ; when others => DISPLAY_ERROR ( "invalid, improper ending entity for exports connection" ) ; raise CONNECT_ERROR_AFTER_START ; end case ; -- EXPORTS_TYPE REFERENCE_MARKER (GKS_SPECIFICATION.VISIBLE, END_POINT) ; -- -- update the TREE nodes -- TREE(START_PARENT).CONNECTEE := END_PARENT ; -- check for matching names, if not then issue warning if TREE( START_PARENT ).NAME /= TREE( END_PARENT ).NAME then VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( TREE( START_PARENT ).NAME , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( TREE( END_PARENT ).NAME , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 24 ) ) ; DISPLAY_ERROR ( "WARNING the entity names do not match " ) ; end if ; begin -- get the connection REQUEST_CONNECTION (START_PARENT, START_POINT, END_POINT, CONNECTION) ; exception when OPERATION_ABORTED_BY_OPERATOR => -- restore the tree TREE(START_PARENT).CONNECTEE := NULL_POINTER ; raise ; -- reference markers turned off later when others => raise ; end ; TREE(START_PARENT).LINE := CONNECTION ; MAKE_REFERENCE(START_PARENT, END_PARENT) ; -- turn off the markers REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, START_POINT) ; REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, END_POINT) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when others => -- this should not occur null ; end case ; -- COMMAND exception when HANDLE_RESTART => -- exception used to return to the main menu raise ; when HANDLE_ABORT_BACKUP => -- execption used to return to create menu GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when CONNECT_ERROR_AFTER_START => -- turn off the marker REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, START_POINT) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when CREATION_ERROR => -- user already notified of error, -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when OPERATION_ABORTED_BY_OPERATOR => -- turn off the marker REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, START_POINT) ; REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, END_POINT) ; raise ; when others => -- handle error conditions that might occur -- turn off the marker REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, START_POINT) ; REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, END_POINT) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR in CREATE_CONNECTION ") ; TRACE_PKG.TRACE (" PROGRAM ERROR in CREATE_CONNECTION !!!!! ") ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; end CREATE_CONNECTION ; function CONTROL_ANNOTATING_MENU return COMMAND_TYPE is -- ========================================================= -- This procedure performs operations required to implement -- the add menu commands. -- ========================================================= use TREE_DATA ; ANNOTATING_ERROR : EXCEPTION ; COMMAND, DUMMY : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DONE : BOOLEAN := FALSE ; ENTITY_NAME : TREE_DATA.NAME_TYPE := TREE_DATA.NULL_NAME ; ENTRY_POINT_STAT : COMMAND_TYPE := COMMAND_TYPE'(UNGUARDED_CMD) ; GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; END_GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE ; SIZE_POINT , LABEL_POINT : GRAPHICS_DATA.POINT ; LABEL_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; LOCATION : GRAPHICS_DATA.POINT ; PARAM_STATUS : COMMAND_TYPE := COMMAND_TYPE'(NO_PARAMETERS_CMD) ; PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; PARENT_ENTITY : GRAPHICS_DATA.GRAPHIC_ENTITY := PACKAGE_FIGURE ; TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; END_TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; START_POINT : GRAPHICS_DATA.POINT ; END_POINT : GRAPHICS_DATA.POINT ; CONNECTION : TREE_DATA.LINE_TYPE ; COLOR : GRAPHICS_DATA.COLOR_TYPE ; subtype IE_CONNECTION_TYPE_CMD is COMMAND_TYPE range IE_CALL_CONNECT_CMD .. IE_EXPORT_CONNECT_CMD ; begin -- pre place icon cursor on export_proc_cmd COMMAND := EXPORT_PROC_CMD ; while not DONE loop begin -- display the current menu and get command from GRAPHICS_DRIVER DISPLAY_MENU_AND_GET_COMMAND( MENU_ID'( ANNOTATING_MENU ) , COMMAND ) ; case COMMAND is -- implement the menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( ANNOTATING_MENU ) ) ; when BACKUP_CMD => -- return to the next higher menu DONE := true ; -- exit the loop when RESTART_CMD => -- return to the main menu raise HANDLE_RESTART ; when PAN_ZOOM_CMD => -- go execute pan zoom operations, return to here DUMMY := CONTROL_PAN_ZOOM_MENU ; when EXPORT_TASK_ENTRY_CMD => -- add an exported entry point declaration -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- turn on abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- request the user identify the scope for entry REQUEST_POINT ("enter point identifying scope and vertical position of export entry point ", LOCATION, PARENT, LABEL_CREATE => LABEL_EXPORT ) ; -- turn off abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for a valid parent if PARENT = NULL_POINTER or else TREE(PARENT).NODE_TYPE not in TYPE_VIRTUAL_PACKAGE .. TYPE_PACKAGE then DISPLAY_ERROR (" invalid scope for exported entry point ") ; raise ANNOTATING_ERROR ; end if ; -- determine color for display PARENT_ENTITY := UTIL_FOR_TREE.GET_FIGURE_TYPE ( TREE(PARENT).NODE_TYPE ) ; COLOR := ENTITY_COLOR (PARENT_ENTITY) ; -- prompt user for export name REQUEST_LABEL ( ENTITY_NAME ) ; -- output the label for the export symbol -- get the TREE and GRAPH nodes -- begin TREE_NODE := GET_NEW_TREE_NODE (EXPORTED_ENTRY_POINT) ; TREE(TREE_NODE).NAME := ENTITY_NAME ; SET_PARENT (TREE_NODE, PARENT, EXPORTED_LIST) ; GRAPH_NODE := GET_NEW_GRAPH_NODE (TREE_NODE) ; TREE(TREE_NODE).GRAPH_DATA := GRAPH_NODE ; LOCATION.X := GRAPH(TREE(PARENT).GRAPH_DATA). DATA.LOCATION.X - IMPORT_EXPORT_X_OFFSET ; GRAPH(GRAPH_NODE).DATA.LOCATION := LOCATION ; LABEL( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION ( GRAPH_NODE ) , GET_LABEL_STRING ( TREE_NODE ) , COLOR ) ; GRAPH(GRAPH_NODE).DATA.SIZE := SIZE_POINT ; GRAPH(GRAPH_NODE).DATA.SEGMENT_ID := NULL_SEGMENT ; GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; -- immediately get the connection from an exported task -- entry start point at right side of annotation START_POINT := SIZE_POINT ; REFERENCE_MARKER (GKS_SPECIFICATION.VISIBLE, START_POINT) ; -- allow retry for line connection CONNECT_TO_ENTRY_POINT_LOOP : loop begin -- turn on abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; REQUEST_POINT ( "pick entry point as end point for required connection" , END_POINT , END_TREE_NODE ) ; -- turn off abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for valid end parent for the connection if ( TREE(END_TREE_NODE).NODE_TYPE /= TYPE_ENTRY_POINT ) and ( TREE(END_TREE_NODE).NODE_TYPE /= EXPORTED_ENTRY_POINT ) then DISPLAY_ERROR ( "invalid, must connect to entry point" ) ; raise ANNOTATING_ERROR ; end if ; END_GRAPH_NODE := TREE(END_TREE_NODE).GRAPH_DATA ; END_POINT := GRAPH(END_GRAPH_NODE).DATA.LOCATION ; -- scope check the export to entry point connection begin if TREE( TREE_NODE ).PARENT /= TREE( TREE(END_TREE_NODE).PARENT ).PARENT then raise ANNOTATING_ERROR ; end if ; exception when others => -- handler if .parent) .parent) produces error DISPLAY_ERROR ( "invalid, improper scoping for connection" ) ; raise ANNOTATING_ERROR ; end ; exit CONNECT_TO_ENTRY_POINT_LOOP ; exception when ANNOTATING_ERROR => -- error already displayed, stay in loop null ; when others => -- an ABORT or some unknown error raise ; end ; end loop CONNECT_TO_ENTRY_POINT_LOOP ; REFERENCE_MARKER (GKS_SPECIFICATION.VISIBLE, END_POINT) ; -- -- update the TREE nodes TREE(TREE_NODE).CONNECTEE := END_TREE_NODE ; -- check for matching names, if not then issue warning if TREE( TREE_NODE ).NAME /= TREE( END_TREE_NODE ).NAME then VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( TREE( TREE_NODE ).NAME , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( TREE( END_TREE_NODE ).NAME , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 24 ) ) ; DISPLAY_ERROR ( "WARNING the entity names do not match " ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; end if ; -- get the connection REQUEST_CONNECTION (TREE_NODE, START_POINT, END_POINT, CONNECTION) ; TREE(TREE_NODE).LINE := CONNECTION ; MAKE_REFERENCE(TREE_NODE, END_TREE_NODE) ; -- turn off the markers REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, START_POINT) ; REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, END_POINT) ; exception -- release the allocated node on error when OPERATION_ABORTED_BY_OPERATOR => TREE_OPS.RELEASE_TREE_NODE( TREE_NODE ) ; GRAPHIC_DRIVER.DELETE_SEGMENT( LABEL_SEGMENT ) ; -- turn off the markers REFERENCE_MARKER( GKS_SPECIFICATION.INVISIBLE, START_POINT ) ; REFERENCE_MARKER( GKS_SPECIFICATION.INVISIBLE, END_POINT ) ; raise ; when others => TREE_OPS.RELEASE_TREE_NODE( TREE_NODE ) ; GRAPHIC_DRIVER.DELETE_SEGMENT ( LABEL_SEGMENT ) ; -- turn off the markers REFERENCE_MARKER( GKS_SPECIFICATION.INVISIBLE, START_POINT ) ; REFERENCE_MARKER( GKS_SPECIFICATION.INVISIBLE, END_POINT ) ; -- turn off abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF); -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; raise ; end ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when EXPORT_TYPE_CMD | EXPORT_OBJ_CMD | EXPORT_EXCEPT_CMD | EXPORT_PROC_CMD | EXPORT_FUNC_CMD => -- add an exported type, object, exception, procedure, -- or function declaration -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- turn on abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- request the user identify the scope to be deleted REQUEST_POINT (" enter point identifying scope and vertical position of export", LOCATION, PARENT, LABEL_CREATE => LABEL_EXPORT ) ; -- turn off abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for a valid parent if PARENT = NULL_POINTER or else ( TREE(PARENT).NODE_TYPE /= TYPE_PACKAGE and TREE(PARENT).NODE_TYPE /= TYPE_VIRTUAL_PACKAGE ) then DISPLAY_ERROR (" invalid scope for export declaration ") ; raise ANNOTATING_ERROR ; end if ; -- determine color for display PARENT_ENTITY := UTIL_FOR_TREE.GET_FIGURE_TYPE ( TREE(PARENT).NODE_TYPE ) ; COLOR := ENTITY_COLOR (PARENT_ENTITY) ; -- prompt user for export name if COMMAND = EXPORT_FUNC_CMD then REQUEST_LABEL ( ENTITY_NAME, FALSE, TRUE ) ; else REQUEST_LABEL ( ENTITY_NAME ) ; end if ; -- output the label for the export symbol -- get the TREE and GRAPH nodes begin if COMMAND = EXPORT_TYPE_CMD then TREE_NODE := GET_NEW_TREE_NODE (EXPORTED_TYPE) ; elsif COMMAND = EXPORT_OBJ_CMD then TREE_NODE := GET_NEW_TREE_NODE (EXPORTED_OBJECT) ; elsif COMMAND = EXPORT_EXCEPT_CMD then TREE_NODE := GET_NEW_TREE_NODE (EXPORTED_EXCEPTION) ; elsif COMMAND = EXPORT_PROC_CMD then TREE_NODE := GET_NEW_TREE_NODE (EXPORTED_PROCEDURE) ; else TREE_NODE := GET_NEW_TREE_NODE (EXPORTED_FUNCTION) ; end if ; -- -- update the TREE and GRAPH nodes -- TREE(TREE_NODE).NAME := ENTITY_NAME ; SET_PARENT (TREE_NODE, PARENT, EXPORTED_LIST) ; GRAPH_NODE := GET_NEW_GRAPH_NODE (TREE_NODE) ; TREE(TREE_NODE).GRAPH_DATA := GRAPH_NODE ; LOCATION.X := GRAPH(TREE(PARENT).GRAPH_DATA). DATA.LOCATION.X - IMPORT_EXPORT_X_OFFSET ; GRAPH(GRAPH_NODE).DATA.LOCATION := LOCATION ; -- display the label and get the size pt and segment id LABEL( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION ( GRAPH_NODE ) , GET_LABEL_STRING ( TREE_NODE ) , COLOR ) ; -- place the graph information in the graph node GRAPH(GRAPH_NODE).DATA.SIZE := SIZE_POINT ; GRAPH(GRAPH_NODE).DATA.SEGMENT_ID := NULL_SEGMENT ; GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; exception -- release the allocated node on error when others => TREE_OPS.RELEASE_TREE_NODE( TREE_NODE ) ; raise ; end ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when IMPORT_VP_CMD | IMPORT_PKG_CMD | IMPORT_PROC_CMD | IMPORT_FUNC_CMD => -- add an imported virtual package, package, procedure -- or function -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- turn on abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- request the user identify the scope to be deleted REQUEST_POINT (" enter point identifying scope and vertical position of import ", LOCATION, PARENT, LABEL_CREATE => LABEL_IMPORT ) ; -- turn off abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for a valid parent if PARENT = NULL_POINTER or else ( TREE(PARENT).NODE_TYPE /= TYPE_PACKAGE and TREE(PARENT).NODE_TYPE /= TYPE_VIRTUAL_PACKAGE ) then DISPLAY_ERROR (" invalid scope for import declaration ") ; raise ANNOTATING_ERROR ; end if ; if TREE(PARENT).PARENT /= ROOT_NODE then DISPLAY_ERROR (" invalid, only outer most scope is valid for import declaration ") ; raise ANNOTATING_ERROR ; end if ; -- determine color for display PARENT_ENTITY := UTIL_FOR_TREE.GET_FIGURE_TYPE ( TREE(PARENT).NODE_TYPE ) ; COLOR := ENTITY_COLOR (PARENT_ENTITY) ; -- prompt user for import name if COMMAND = IMPORT_FUNC_CMD then REQUEST_LABEL ( ENTITY_NAME, FALSE, TRUE ) ; else REQUEST_LABEL ( ENTITY_NAME ) ; end if ; -- get the TREE and GRAPH node begin if COMMAND = IMPORT_VP_CMD then TREE_NODE := GET_NEW_TREE_NODE (IMPORTED_VIRTUAL_PACKAGE) ; elsif COMMAND = IMPORT_PKG_CMD then TREE_NODE := GET_NEW_TREE_NODE (IMPORTED_PACKAGE) ; elsif COMMAND = IMPORT_PROC_CMD then TREE_NODE := GET_NEW_TREE_NODE (IMPORTED_PROCEDURE) ; else TREE_NODE := GET_NEW_TREE_NODE (IMPORTED_FUNCTION) ; end if ; -- -- update the TREE and GRAPH nodes -- TREE(TREE_NODE).NAME := ENTITY_NAME ; SET_PARENT (TREE_NODE, PARENT, IMPORTED_LIST) ; GRAPH_NODE := GET_NEW_GRAPH_NODE (TREE_NODE) ; TREE(TREE_NODE).GRAPH_DATA := GRAPH_NODE ; LOCATION.X := GRAPH(TREE(PARENT).GRAPH_DATA). DATA.SIZE.X - IMPORT_EXPORT_X_OFFSET ; GRAPH(GRAPH_NODE).DATA.LOCATION := LOCATION ; -- display the label and get the size pt and segment id LABEL( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION ( GRAPH_NODE ) , GET_LABEL_STRING ( TREE_NODE ) , COLOR ) ; -- place the graph information in the graph node GRAPH(GRAPH_NODE).DATA.SIZE := SIZE_POINT ; GRAPH(GRAPH_NODE).DATA.SEGMENT_ID := NULL_SEGMENT ; GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; exception -- release the allocated node on error when others => TREE_OPS.RELEASE_TREE_NODE( TREE_NODE ) ; raise ; end ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when IE_CONNECTION_TYPE_CMD => CREATE_CONNECTION( COMMAND ) ; when others => -- this should not occur null ; end case ; -- COMMAND exception when HANDLE_RESTART => -- propogate exception to handle return to main menu GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; raise ; when ANNOTATING_ERROR => -- error previously called to user's attention -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when OPERATION_ABORTED_BY_OPERATOR => -- turn off abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF); -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when others => -- handle error conditions that might occur -- turn off the markers REFERENCE_MARKER( GKS_SPECIFICATION.INVISIBLE, LOCATION ) ; REFERENCE_MARKER( GKS_SPECIFICATION.INVISIBLE, LOCATION ) ; -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in ANNOTATING Menu ") ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; end ; end loop ; -- return the command processed return COMMAND ; end CONTROL_ANNOTATING_MENU ; end MMI_ATTRIBUTES ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --mmi_design_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-09-05 1535 by RAM package MMI_DESIGN is -- ============================================================= -- -- This package implements the design capability of the -- Man-Machine Interface. It controls the DESIGN_MENU -- and all subordinate menus, both in terms of displaying -- the menus and implementing their implied functionality. -- -- ============================================================= procedure CONTROL_DESIGN_MENU ; -- ========================================================= -- This procedure performs operations required to implement -- the design menu commands. -- ========================================================= end MMI_DESIGN ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --mmi_design_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-02-12 14:00 by JB with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; with GRAPHICS_DATA ; use GRAPHICS_DATA ; with GRAPHIC_DRIVER ; use GRAPHIC_DRIVER ; with MMI_CONTROL_MENUS ; use MMI_CONTROL_MENUS ; with MMI_PARAMETERS ; use MMI_PARAMETERS ; with MMI_ATTRIBUTES ; use MMI_ATTRIBUTES ; with TRACE_PKG ; with TREE_DATA ; use TREE_DATA ; with TREE_OPS ; use TREE_OPS ; with UTILITIES ; use UTILITIES ; with UTIL_FOR_TREE ; use UTIL_FOR_TREE ; with VIRTUAL_TERMINAL_INTERFACE ; use VIRTUAL_TERMINAL_INTERFACE ; package body MMI_DESIGN is procedure UPDATE_TREE_FOR_CONTAINED_ENTITIES ( PARENT : in out TREE_DATA.TREE_NODE_ACCESS_TYPE ; TREE_NODE : in out TREE_DATA.TREE_NODE_ACCESS_TYPE ; ENCLOSED_ENTITIES : in out TREE_DATA.ENCLOSED_ENTITIES_TYPE ) is -- ========================================================= -- This procedure updates the tree for the entities -- in the received list. -- ========================================================= ENCLOSED_INDEX : INTEGER := ENCLOSED_ENTITIES'first ; LIST_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; SEARCH_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; MEMBER_PTR : TREE_DATA.MEMBERSHIP_LIST_TYPE ; NEW_LIST_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE := TREE_DATA.NULL_POINTER ; begin -- Process each entity contained in the received list of -- contained entities. LIST_PTR := ENCLOSED_ENTITIES( ENCLOSED_INDEX ) ; while LIST_PTR /= TREE_DATA.NULL_POINTER loop -- Remove the contained entities from the contained entity -- list of the parent. -- If the first item of the contained list is the item to be -- deleted then remove the item from the list. if LIST_PTR = TREE_DATA.TREE( PARENT ).CONTAINED_ENTITY_LIST then TREE_DATA.TREE( PARENT ).CONTAINED_ENTITY_LIST := TREE_DATA.LIST( LIST_PTR ).NEXT ; TREE_DATA.LIST( TREE_DATA.TREE( PARENT ).CONTAINED_ENTITY_LIST ).PRIOR := TREE_DATA.NULL_POINTER ; else -- Search for the list item to be delete from the contained -- entity list; when found, delete the item from the list. SEARCH_PTR := TREE_DATA.TREE( PARENT ).CONTAINED_ENTITY_LIST ; while SEARCH_PTR /= TREE_DATA.NULL_POINTER loop if SEARCH_PTR = LIST_PTR then TREE_DATA.LIST( TREE_DATA.LIST( SEARCH_PTR ).PRIOR ).NEXT := TREE_DATA.LIST( SEARCH_PTR ).NEXT ; if TREE_DATA.LIST( SEARCH_PTR ).NEXT /= TREE_DATA.NULL_POINTER then TREE_DATA.LIST( TREE_DATA.LIST( SEARCH_PTR ).NEXT ).PRIOR := TREE_DATA.LIST( SEARCH_PTR ).PRIOR ; end if ; exit ; else SEARCH_PTR := TREE_DATA.LIST( SEARCH_PTR ).NEXT ; end if ; end loop ; end if ; -- Attach the list node being processed to the contained -- entity list of the new parent. if NEW_LIST_PTR = TREE_DATA.NULL_POINTER then TREE_DATA.TREE( TREE_NODE ).CONTAINED_ENTITY_LIST := LIST_PTR ; TREE_DATA.LIST( LIST_PTR ).PRIOR := TREE_DATA.NULL_POINTER ; else TREE_DATA.LIST( LIST_PTR ).PRIOR := NEW_LIST_PTR ; TREE_DATA.LIST( NEW_LIST_PTR ).NEXT := LIST_PTR ; end if ; -- Update the parent in the membership list of the current -- list node ( the current contained entity ). MEMBER_PTR := TREE_DATA.TREE( TREE_DATA.LIST( LIST_PTR ).ITEM ).MEMBERSHIP ; while MEMBER_PTR /= TREE_DATA.NULL_POINTER loop if TREE_DATA.LIST( MEMBER_PTR ).ITEM = TREE_DATA.TREE( TREE_DATA.LIST( LIST_PTR ).ITEM ).PARENT then TREE_DATA.LIST( MEMBER_PTR ).ITEM := TREE_NODE ; exit ; else MEMBER_PTR := TREE_DATA.LIST( MEMBER_PTR ).NEXT ; end if ; end loop ; -- Update fields NEXT & ITEM for the current list node, and set -- the parent of the tree node associated with the list node NEW_LIST_PTR := LIST_PTR ; TREE_DATA.LIST( LIST_PTR ).NEXT := TREE_DATA.NULL_POINTER ; -- Set the parent to the input tree node. --TREE_DATA.LIST( LIST_PTR ).ITEM := TREE_NODE ; TREE_DATA.TREE( TREE_DATA.LIST( LIST_PTR ).ITEM ).PARENT := TREE_NODE ; -- Determine the next list node to process. ENCLOSED_INDEX := ENCLOSED_INDEX + 1 ; LIST_PTR := ENCLOSED_ENTITIES( ENCLOSED_INDEX ) ; end loop ; end UPDATE_TREE_FOR_CONTAINED_ENTITIES ; procedure CREATE( COMMAND : in COMMAND_TYPE ) is -- ========================================================= -- This procedure performs operations required to implement -- the create menu commands. -- ========================================================= BLANK_LINE : constant String := " " ; BOX_REFERENCE_POINT : GRAPHICS_DATA.POINT ; BOX_SIZE_POINT : GRAPHICS_DATA.POINT ; CALL_STATUS : COMMAND_TYPE := COMMAND_TYPE'(UNCONDITIONAL_CMD) ; CALL_TYPE : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DATA_TYPE : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; EXPORTS_TYPE : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DUMMY : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; CONNECTION : TREE_DATA.LINE_TYPE ; CONNECT_TYPE : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DONE : Boolean := False ; END_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; END_PARENT_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; END_POINT : GRAPHICS_DATA.POINT ; ENTITY_NAME : TREE_DATA.NAME_TYPE := TREE_DATA.NULL_NAME ; ENTITY_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; GENERIC_TYPE : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE := NULL_POINTER ; SIZE_POINT , LABEL_POINT : GRAPHICS_DATA.POINT ; LABEL_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; LINE_POINT : GRAPHICS_DATA.POINT ; PARAM_STATUS : COMMAND_TYPE := COMMAND_TYPE'(NO_PARAMETERS_CMD) ; ENTRY_POINT_STAT : COMMAND_TYPE := COMMAND_TYPE'(UNGUARDED_CMD) ; PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; PROPER_SCOPE : Boolean := False ; SCOPE_SIZE_POINT : GRAPHICS_DATA.POINT ; START_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; L_C_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; START_POINT : GRAPHICS_DATA.POINT ; TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; PROLOGUE_NODE : TREE_DATA.PROLOGUE_NODE_ACCESS_TYPE := NULL_POINTER; ENCLOSED_ENTITIES : TREE_DATA.ENCLOSED_ENTITIES_TYPE ; ENCLOSURE_EXISTS : BOOLEAN ; CREATION_ERROR : exception ; begin case COMMAND is when VIRT_PACKAGE_CMD => -- create a virtual package -- set graphics window active. GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- continue prompting for points until a good entity is drawn loop begin -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get box points in proper scope REQUEST_POINTS (BOX_REFERENCE_POINT, BOX_SIZE_POINT, PARENT, ENCLOSED_ENTITIES, ENCLOSURE_EXISTS ) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check if valid Parent specified if PARENT = NULL_POINTER then DISPLAY_ERROR( " PROGRAM ERROR -- null pointer parent " & "in creating virtual package ") ; raise CREATION_ERROR ; elsif TREE( PARENT ).NODE_TYPE not in ROOT .. TYPE_TASK then DISPLAY_ERROR(" invalid scope due to wrong parent type ") ; raise CREATION_ERROR ; elsif CHECK_IF_GENERIC_INSTAN (PARENT) then DISPLAY_ERROR( " no objects can be placed inside" & " an instantiated unit ") ; raise CREATION_ERROR ; end if ; -- draw the box and set the visibility ENTITY_SEGMENT := GRAPHIC_DRIVER.DRAW_FIGURE ( GRAPHICS_DATA.VIRTUAL_PKG_FIGURE, BOX_REFERENCE_POINT, BOX_SIZE_POINT ) ; exit ; exception when FIGURE_TOO_NARROW => DISPLAY_ERROR(" Figure as defined will be too narrow" & " to draw. " ) ; when others => raise ; end ; end loop ; GRAPHIC_DRIVER.SET_SEGMENT_VISIBILITY( ENTITY_SEGMENT, GKS_SPECIFICATION.VISIBLE ) ; -- If enclosed entities exist then archive the tree if ENCLOSURE_EXISTS then ARCHIVE_THE_TREE ; end if ; -- -- create and update the TREE and GRAPH nodes -- TREE_NODE := GET_NEW_TREE_NODE (TYPE_VIRTUAL_PACKAGE) ; SET_PARENT (TREE_NODE, PARENT, CONTAINED_LIST) ; GRAPH_NODE := GET_NEW_GRAPH_NODE(TREE_NODE) ; TREE(TREE_NODE).GRAPH_DATA := GRAPH_NODE ; -- place the graph information in the graph node GRAPH(GRAPH_NODE).DATA.LOCATION := BOX_REFERENCE_POINT ; GRAPH(GRAPH_NODE).DATA.SIZE := BOX_SIZE_POINT ; GRAPH(GRAPH_NODE).DATA.SEGMENT_ID := ENTITY_SEGMENT ; -- If the created entity encloses previously created -- entities then update and verify the tree. if ENCLOSURE_EXISTS then UPDATE_TREE_FOR_CONTAINED_ENTITIES ( PARENT, TREE_NODE, ENCLOSED_ENTITIES ) ; if not CHECK_IF_ANNOTATED_TREE_VALID then RECOVER_THE_TREE ; raise CREATION_ERROR ; end if ; end if ; -- prompt user for package name. REQUEST_LABEL( ENTITY_NAME ) ; TREE(TREE_NODE).NAME := ENTITY_NAME ; -- label the virtual package LABEL( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION( GRAPH_NODE ) , GET_LABEL_STRING( TREE_NODE ) , ENTITY_COLOR (GRAPHICS_DATA.VIRTUAL_PKG_FIGURE) ) ; GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; PROLOGUE_NODE := GET_NEW_PROLOGUE_NODE (TREE_NODE) ; -- prompt user for PROLOGUE. REQUEST_PROLOGUE(PROLOGUE_NODE) ; TREE(TREE_NODE).PROLOGUE_PTR := PROLOGUE_NODE ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when PACKAGE_CMD => -- check if the package should be generic GENERIC_TYPE := CONTROL_GENERIC_MENU ; -- restore the design menu DISPLAY_MENU( MENU_ID'(DESIGN_MENU), COMMAND ) ; -- set graphics window active. GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- continue prompting for points until a good entity is drawn loop begin -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get box points in proper scope REQUEST_POINTS (BOX_REFERENCE_POINT, BOX_SIZE_POINT, PARENT, ENCLOSED_ENTITIES, ENCLOSURE_EXISTS ) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- test if the parent is valid if PARENT = NULL_POINTER then DISPLAY_ERROR( " PROGRAM ERROR -- null pointer parent in " & "creating package ") ; raise CREATION_ERROR ; elsif TREE( PARENT ).NODE_TYPE not in ROOT .. TYPE_TASK then DISPLAY_ERROR(" invalid scope due to wrong parent type ") ; raise CREATION_ERROR ; elsif CHECK_IF_GENERIC_INSTAN (PARENT) or ( GENERIC_TYPE = GENERIC_INST_CMD and ENCLOSURE_EXISTS ) then DISPLAY_ERROR (" no objects can be placed inside" & " an instantiated unit ") ; raise CREATION_ERROR ; end if ; -- draw the box and set the visibility ENTITY_SEGMENT := GRAPHIC_DRIVER.DRAW_FIGURE ( GRAPHICS_DATA.PACKAGE_FIGURE, BOX_REFERENCE_POINT, BOX_SIZE_POINT ) ; -- points selected were good so continue exit ; exception when FIGURE_TOO_NARROW => DISPLAY_ERROR(" Figure as defined will be too narrow" & " to draw. " ) ; when others => raise ; end ; end loop ; GRAPHIC_DRIVER.SET_SEGMENT_VISIBILITY( ENTITY_SEGMENT, GKS_SPECIFICATION.VISIBLE ) ; -- If enclosed entities exist then archive the tree if ENCLOSURE_EXISTS then ARCHIVE_THE_TREE ; end if ; -- create and update the TREE and GRAPH nodes TREE_NODE := GET_NEW_TREE_NODE (TYPE_PACKAGE) ; SET_PARENT (TREE_NODE, PARENT, CONTAINED_LIST) ; GRAPH_NODE := GET_NEW_GRAPH_NODE(TREE_NODE) ; TREE(TREE_NODE).GRAPH_DATA := GRAPH_NODE ; -- place the graph information in the graph node GRAPH(GRAPH_NODE).DATA.LOCATION := BOX_REFERENCE_POINT ; GRAPH(GRAPH_NODE).DATA.SIZE := BOX_SIZE_POINT ; GRAPH(GRAPH_NODE).DATA.SEGMENT_ID := ENTITY_SEGMENT ; -- If the created entity encloses previously created -- entities then update and verify the tree. if ENCLOSURE_EXISTS then UPDATE_TREE_FOR_CONTAINED_ENTITIES ( PARENT, TREE_NODE, ENCLOSED_ENTITIES ) ; if not CHECK_IF_ANNOTATED_TREE_VALID then RECOVER_THE_TREE ; raise CREATION_ERROR ; end if ; end if ; -- prompt user for package name. REQUEST_LABEL( ENTITY_NAME ) ; TREE(TREE_NODE).NAME := ENTITY_NAME ; -- label the package LABEL( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION( GRAPH_NODE ) , GET_LABEL_STRING( TREE_NODE ) , ENTITY_COLOR (GRAPHICS_DATA.PACKAGE_FIGURE) ) ; GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; -- set the packages generic status case GENERIC_TYPE is when GENERIC_DECL_CMD => TREE(TREE_NODE).GENERIC_STATUS := GENERIC_DECLARATION ; LABEL( LABEL_SEGMENT , SIZE_POINT , GET_GENERIC_OFFSET_LOCATION( GRAPH_NODE ) , GET_GENERIC_LABEL_STRING( TREE_NODE ) , ENTITY_COLOR (GRAPHICS_DATA.PACKAGE_FIGURE) ) ; GRAPH(GRAPH_NODE).DATA.LABEL2_SEG_ID := LABEL_SEGMENT ; when GENERIC_INST_CMD => TREE(TREE_NODE).GENERIC_STATUS := GENERIC_INSTANTIATION ; -- set the CU instantiated REQUEST_LABEL (TREE(TREE_NODE).CU_INSTANTIATED, " enter the name of the compilation" & " unit to be instantiated ") ; LABEL( LABEL_SEGMENT , SIZE_POINT , GET_GENERIC_OFFSET_LOCATION( GRAPH_NODE ) , GET_GENERIC_LABEL_STRING( TREE_NODE ) , ENTITY_COLOR (GRAPHICS_DATA.PACKAGE_FIGURE) ) ; GRAPH(GRAPH_NODE).DATA.LABEL2_SEG_ID := LABEL_SEGMENT ; when others => TREE(TREE_NODE).GENERIC_STATUS := NOT_GENERIC ; end case ; PROLOGUE_NODE := GET_NEW_PROLOGUE_NODE (TREE_NODE) ; -- prompt user for PROLOGUE. REQUEST_PROLOGUE(PROLOGUE_NODE) ; TREE(TREE_NODE).PROLOGUE_PTR := PROLOGUE_NODE ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when TASK_CMD => -- create a task -- set graphics window active. GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- continue prompting for points until a good entity is drawn loop begin -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get box points in proper scope REQUEST_POINTS (BOX_REFERENCE_POINT, BOX_SIZE_POINT, PARENT, ENCLOSED_ENTITIES, ENCLOSURE_EXISTS ) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for valid parent for a task if PARENT = ROOT_NODE then DISPLAY_ERROR( " invalid, tasks must be placed within " & "packages or subprograms ") ; raise CREATION_ERROR ; elsif TREE( PARENT ).NODE_TYPE not in TYPE_VIRTUAL_PACKAGE .. TYPE_TASK then DISPLAY_ERROR(" invalid scope due to wrong parent type "); raise CREATION_ERROR ; elsif CHECK_IF_GENERIC_INSTAN (PARENT) then DISPLAY_ERROR (" no objects can be placed inside" & " an instantiated unit ") ; raise CREATION_ERROR ; end if ; -- draw the task and set the visibility ENTITY_SEGMENT := GRAPHIC_DRIVER.DRAW_FIGURE ( GRAPHICS_DATA.TASK_FIGURE, BOX_REFERENCE_POINT, BOX_SIZE_POINT ) ; -- points selected were good so continue exit ; exception when FIGURE_TOO_NARROW => DISPLAY_ERROR(" Figure as defined will be too narrow" & " to draw. " ) ; when others => raise ; end ; end loop ; GRAPHIC_DRIVER.SET_SEGMENT_VISIBILITY( ENTITY_SEGMENT, GKS_SPECIFICATION.VISIBLE ) ; -- If enclosed entities exist then archive the tree if ENCLOSURE_EXISTS then ARCHIVE_THE_TREE ; end if ; -- create and update the TREE and GRAPH nodes TREE_NODE := GET_NEW_TREE_NODE (TYPE_TASK) ; SET_PARENT (TREE_NODE, PARENT, CONTAINED_LIST) ; GRAPH_NODE := GET_NEW_GRAPH_NODE(TREE_NODE) ; TREE(TREE_NODE).GRAPH_DATA := GRAPH_NODE ; -- place the graph information in the graph node GRAPH(GRAPH_NODE).DATA.LOCATION := BOX_REFERENCE_POINT ; GRAPH(GRAPH_NODE).DATA.SIZE := BOX_SIZE_POINT ; GRAPH(GRAPH_NODE).DATA.SEGMENT_ID := ENTITY_SEGMENT ; -- If the created entity encloses previously created -- entities then update and verify the tree. if ENCLOSURE_EXISTS then UPDATE_TREE_FOR_CONTAINED_ENTITIES ( PARENT, TREE_NODE, ENCLOSED_ENTITIES ) ; if not CHECK_IF_ANNOTATED_TREE_VALID then RECOVER_THE_TREE ; raise CREATION_ERROR ; end if ; end if ; -- prompt user for package name. REQUEST_LABEL( ENTITY_NAME ) ; TREE(TREE_NODE).NAME := ENTITY_NAME ; -- label the drawn task LABEL( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION( GRAPH_NODE ) , GET_LABEL_STRING( TREE_NODE ) , ENTITY_COLOR (GRAPHICS_DATA.TASK_FIGURE) ) ; GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; PROLOGUE_NODE := GET_NEW_PROLOGUE_NODE (TREE_NODE) ; -- prompt user for PROLOGUE. REQUEST_PROLOGUE(PROLOGUE_NODE) ; TREE(TREE_NODE).PROLOGUE_PTR := PROLOGUE_NODE ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when ENTRY_PT_CMD => -- add an entry point declaration -- get entry point status for a real task entry point ENTRY_POINT_STAT := CONTROL_ENTRY_POINT_STATUS_MENU ; PARAM_STATUS := CONTROL_PARAMETER_STATUS_MENU ; -- set graphics window active GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- request the user identify the scope for entry REQUEST_POINT ("enter point identifying scope and vertical position of entry point", LABEL_POINT, PARENT, LABEL_CREATE => LABEL_EXPORT ) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for a valid parent if PARENT = NULL_POINTER or else TREE(PARENT).NODE_TYPE /= TYPE_TASK then DISPLAY_ERROR (" invalid, entry point must be placed within a task ") ; raise CREATION_ERROR ; end if ; -- prompt user for export name. REQUEST_LABEL( ENTITY_NAME ) ; -- -- create and update the TREE and GRAPH nodes -- TREE_NODE := GET_NEW_TREE_NODE (TYPE_ENTRY_POINT) ; SET_PARENT (TREE_NODE, PARENT, ENTRY_LIST) ; if ENTRY_POINT_STAT = GUARDED_CMD then TREE(TREE_NODE).IS_GUARDED := TRUE ; end if ; if PARAM_STATUS = HAS_PARAMETERS_CMD then TREE(TREE_NODE).WITH_PARAMETERS := TRUE ; end if ; TREE(TREE_NODE).NAME := ENTITY_NAME ; GRAPH_NODE := GET_NEW_GRAPH_NODE(TREE_NODE) ; TREE(TREE_NODE).GRAPH_DATA := GRAPH_NODE ; -- place the graph information in the graph node LABEL_POINT.X := GRAPHIC_DRIVER.PARALLELOGRAM_POINTS ( GRAPH(TREE(PARENT).GRAPH_DATA).DATA.LOCATION , GRAPH(TREE(PARENT).GRAPH_DATA).DATA.SIZE , LABEL_POINT.Y ) - IMPORT_EXPORT_X_OFFSET ; GRAPH(GRAPH_NODE).DATA.LOCATION := LABEL_POINT ; LABEL( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION ( GRAPH_NODE ) , GET_LABEL_STRING ( TREE_NODE ) , ENTITY_COLOR ( GET_FIGURE_TYPE ( TREE(PARENT).NODE_TYPE ) ) ) ; -- -- place the graph information in the graph node GRAPH(GRAPH_NODE).DATA.SIZE := SIZE_POINT ; GRAPH(GRAPH_NODE).DATA.SEGMENT_ID := NULL_SEGMENT ; GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when PROCEDURE_CMD | FUNCTION_CMD => -- create a procedure or function -- check if the package should be generic GENERIC_TYPE := CONTROL_GENERIC_MENU ; -- check the parameter status PARAM_STATUS := CONTROL_PARAMETER_STATUS_MENU ; -- restore the design menu DISPLAY_MENU( MENU_ID'(DESIGN_MENU), COMMAND ) ; -- set graphics window active. GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- continue prompting for points until a good entity is drawn loop begin -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get box points in proper scope REQUEST_POINTS (BOX_REFERENCE_POINT, BOX_SIZE_POINT, PARENT, ENCLOSED_ENTITIES, ENCLOSURE_EXISTS ) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for valid parent for subprogram if PARENT = NULL_POINTER or else TREE(PARENT).NODE_TYPE not in ROOT .. TYPE_TASK then DISPLAY_ERROR(" invalid scope due to wrong parent type ") ; raise CREATION_ERROR ; elsif CHECK_IF_GENERIC_INSTAN (PARENT) or ( GENERIC_TYPE = GENERIC_INST_CMD and ENCLOSURE_EXISTS ) then DISPLAY_ERROR (" no objects can be placed inside" & " an instantiated unit ") ; raise CREATION_ERROR ; end if ; -- draw the subprogram and set the visibility ENTITY_SEGMENT := GRAPHIC_DRIVER.DRAW_FIGURE ( GRAPHICS_DATA.SUBPROGRAM_FIGURE, BOX_REFERENCE_POINT, BOX_SIZE_POINT ) ; -- points selected were good so continue exit ; exception when FIGURE_TOO_NARROW => DISPLAY_ERROR(" Figure as defined will be too narrow" & " to draw. " ) ; when others => raise ; end ; end loop ; GRAPHIC_DRIVER.SET_SEGMENT_VISIBILITY( ENTITY_SEGMENT, GKS_SPECIFICATION.VISIBLE ) ; -- If enclosed entities exist then archive the tree if ENCLOSURE_EXISTS then ARCHIVE_THE_TREE ; end if ; -- create and update the TREE and GRAPH nodes if COMMAND = PROCEDURE_CMD then TREE_NODE := GET_NEW_TREE_NODE (TYPE_PROCEDURE) ; else TREE_NODE := GET_NEW_TREE_NODE (TYPE_FUNCTION) ; end if ; SET_PARENT (TREE_NODE, PARENT, CONTAINED_LIST) ; GRAPH_NODE := GET_NEW_GRAPH_NODE(TREE_NODE) ; TREE(TREE_NODE).GRAPH_DATA := GRAPH_NODE ; if PARAM_STATUS = HAS_PARAMETERS_CMD then TREE(TREE_NODE).HAS_PARAMETERS := TRUE ; end if ; -- place the graph information in the graph node GRAPH(GRAPH_NODE).DATA.LOCATION := BOX_REFERENCE_POINT ; GRAPH(GRAPH_NODE).DATA.SIZE := BOX_SIZE_POINT ; GRAPH(GRAPH_NODE).DATA.SEGMENT_ID := ENTITY_SEGMENT ; -- If the created entity encloses previously created -- entities then update and verify the tree. if ENCLOSURE_EXISTS then UPDATE_TREE_FOR_CONTAINED_ENTITIES ( PARENT, TREE_NODE, ENCLOSED_ENTITIES ) ; if not CHECK_IF_ANNOTATED_TREE_VALID then RECOVER_THE_TREE ; raise CREATION_ERROR ; end if ; end if ; -- prompt user for subprogram name. if COMMAND = PROCEDURE_CMD then REQUEST_LABEL( ENTITY_NAME ) ; else -- functions allow overloading REQUEST_LABEL( ENTITY_NAME, FALSE, TRUE ) ; end if ; TREE(TREE_NODE).NAME := ENTITY_NAME ; -- label the drawn subprogram LABEL( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION( GRAPH_NODE ) , GET_LABEL_STRING( TREE_NODE ) , ENTITY_COLOR (GRAPHICS_DATA.SUBPROGRAM_FIGURE) ) ; GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; -- set the packages generic status case GENERIC_TYPE is when GENERIC_DECL_CMD => TREE(TREE_NODE).GENERIC_STATUS := GENERIC_DECLARATION ; LABEL( LABEL_SEGMENT , SIZE_POINT , GET_GENERIC_OFFSET_LOCATION( GRAPH_NODE ) , GET_GENERIC_LABEL_STRING( TREE_NODE ) , ENTITY_COLOR (GRAPHICS_DATA.SUBPROGRAM_FIGURE)) ; GRAPH(GRAPH_NODE).DATA.LABEL2_SEG_ID := LABEL_SEGMENT ; when GENERIC_INST_CMD => TREE(TREE_NODE).GENERIC_STATUS := GENERIC_INSTANTIATION ; -- set the CU instantiated if COMMAND = PROCEDURE_CMD then REQUEST_LABEL (TREE(TREE_NODE).CU_INSTANTIATED, " enter the name of the compilation" & " unit to be instantiated ") ; else -- function can be overloaded REQUEST_LABEL (TREE(TREE_NODE).CU_INSTANTIATED, " enter the name of the compilation" & " unit to be instantiated ", FALSE, TRUE ) ; end if ; LABEL( LABEL_SEGMENT , SIZE_POINT , GET_GENERIC_OFFSET_LOCATION( GRAPH_NODE ) , GET_GENERIC_LABEL_STRING( TREE_NODE ) , ENTITY_COLOR( GRAPHICS_DATA.SUBPROGRAM_FIGURE)) ; GRAPH(GRAPH_NODE).DATA.LABEL2_SEG_ID := LABEL_SEGMENT ; when others => TREE(TREE_NODE).GENERIC_STATUS := NOT_GENERIC ; end case ; PROLOGUE_NODE := GET_NEW_PROLOGUE_NODE (TREE_NODE) ; -- prompt user for PROLOGUE. REQUEST_PROLOGUE(PROLOGUE_NODE) ; TREE(TREE_NODE).PROLOGUE_PTR := PROLOGUE_NODE ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when ANNOTATION_CMD => DUMMY := CONTROL_ANNOTATING_MENU ; when BODY_CMD => -- create a body -- set graphics window active. GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- continue prompting for points until a good entity is drawn loop begin -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- get box points in proper scope REQUEST_POINTS (BOX_REFERENCE_POINT, BOX_SIZE_POINT, PARENT, ENCLOSED_ENTITIES, ENCLOSURE_EXISTS ) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- check for valid parent for a body if PARENT = NULL_POINTER or else TREE(PARENT).NODE_TYPE not in TYPE_VIRTUAL_PACKAGE .. TYPE_TASK then DISPLAY_ERROR(" invalid scope due to wrong parent type ") ; raise CREATION_ERROR ; elsif CHECK_IF_GENERIC_INSTAN (PARENT) then DISPLAY_ERROR (" no objects can be placed inside" & " an instantiated unit ") ; raise CREATION_ERROR ; elsif TREE(PARENT).BODY_PTR /= NULL_POINTER then DISPLAY_ERROR( " invalid, parent already has an " & "executing body "); raise CREATION_ERROR ; end if ; -- load the proper body color case TREE(PARENT).NODE_TYPE is when TYPE_VIRTUAL_PACKAGE => ENTITY_COLOR(BODY_FIGURE) := ENTITY_COLOR (VIRTUAL_PKG_FIGURE) ; when TYPE_PACKAGE => ENTITY_COLOR(BODY_FIGURE) := ENTITY_COLOR (PACKAGE_FIGURE) ; when TYPE_PROCEDURE | TYPE_FUNCTION => ENTITY_COLOR(BODY_FIGURE) := ENTITY_COLOR (SUBPROGRAM_FIGURE) ; when TYPE_TASK => ENTITY_COLOR(BODY_FIGURE) := ENTITY_COLOR (TASK_FIGURE) ; when others => null ; end case ; -- draw the body and set the visibility ENTITY_SEGMENT := GRAPHIC_DRIVER.DRAW_FIGURE ( GRAPHICS_DATA.BODY_FIGURE, BOX_REFERENCE_POINT, BOX_SIZE_POINT ) ; -- points selected were good so continue exit ; exception when FIGURE_TOO_NARROW => DISPLAY_ERROR(" Figure as defined will be too narrow" & " to draw. " ) ; when others => raise ; end ; end loop ; GRAPHIC_DRIVER.SET_SEGMENT_VISIBILITY( ENTITY_SEGMENT, GKS_SPECIFICATION.VISIBLE ) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; -- -- create and update the TREE and GRAPH nodes -- TREE_NODE := GET_NEW_TREE_NODE (TYPE_BODY) ; TREE(TREE_NODE).NAME := TREE_DATA.NULL_NAME ; TREE(PARENT).BODY_PTR := TREE_NODE ; TREE(TREE_NODE).PARENT := PARENT ; MAKE_REFERENCE( PARENT, TREE_NODE ) ; GRAPH_NODE := GET_NEW_GRAPH_NODE(TREE_NODE) ; TREE(TREE_NODE).GRAPH_DATA := GRAPH_NODE ; -- place the graph information in the graph node GRAPH(GRAPH_NODE).DATA.LOCATION := BOX_REFERENCE_POINT ; GRAPH(GRAPH_NODE).DATA.SIZE := BOX_SIZE_POINT ; GRAPH(GRAPH_NODE).DATA.SEGMENT_ID := ENTITY_SEGMENT ; when others => -- this should not occur null ; end case ; -- COMMAND exception when HANDLE_RESTART => -- exception used to return to the main menu raise ; when HANDLE_ABORT_BACKUP => -- execption used to return to create menu GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when CREATION_ERROR => -- user already notified of error, -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when OPERATION_ABORTED_BY_OPERATOR => -- turn off any possible markers REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, START_POINT) ; REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, END_POINT) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when others => -- handle error conditions that might occur -- turn off the marker REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, START_POINT) ; REFERENCE_MARKER (GKS_SPECIFICATION.INVISIBLE, END_POINT) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in CREATING requested object ") ; TRACE_PKG.TRACE (" PROGRAM ERROR in MMI_DESIGN.CREATE !!!!! ") ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; end CREATE ; procedure MODIFY_PROLOGUE ( TREE_NODE : in TREE_DATA.PROLOGUE_NODE_ACCESS_TYPE ) is -- ========================================================= -- This procedure allows the modification of the PROLOGUE -- ========================================================= BLANK_PROLOGUE_LINE : PROLOGUE_LINE := (others => ' ') ; DATA_LINE : PROLOGUE_LINE ; INDICATOR : STRING (1..3) := " " ; PROMPT : STRING (1..DATA_LINE'length+INDICATOR'length) ; PROLOGUE_NODE : TREE_DATA.PROLOGUE_NODE_ACCESS_TYPE ; -- start PROLOGUE display(blank line before and after) START_LINE : NATURAL := 23 - (2 + PROLOGUE_COUNT) ; begin PROLOGUE_NODE := TREE(TREE_NODE).PROLOGUE_PTR ; for I in 1 .. PROLOGUE_COUNT loop -- display the current PROLOGUE lines INDICATOR := " " ; PROMPT := INDICATOR & BLANK_PROLOGUE_LINE ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( PROMPT , CURSOR_ADDRESS'(WRITE_WITH_ADDRESS), ROW_NO( START_LINE ), COL_NO( 1 ) ) ; for J in 1 .. PROLOGUE_COUNT loop if J = I then INDICATOR := "=> " ; else INDICATOR := " " ; end if ; PROMPT := INDICATOR & PROLOGUE(PROLOGUE_NODE).DATA(J) ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( PROMPT , CURSOR_ADDRESS'(WRITE_WITH_ADDRESS), ROW_NO( START_LINE+J ), COL_NO( 1 ) ) ; end loop ; INDICATOR := " " ; PROMPT := INDICATOR & BLANK_PROLOGUE_LINE ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( PROMPT , CURSOR_ADDRESS'(WRITE_WITH_ADDRESS), ROW_NO( START_LINE+PROLOGUE_COUNT+1 ), COL_NO( 1 ) ) ; -- Prompt the operator for the line. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "Replace PROLOGUE text line" & INTEGER'image(I) & ", blank or (cr) = no change " , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- Retrieve the operator specified line DATA_LINE := BLANK_PROLOGUE_LINE ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( DATA_LINE , CURSOR_ADDRESS'(WRITE_WITH_ADDRESS), ROW_NO( 24 ) , COL_NO( 1 ) ) ; VIRTUAL_TERMINAL_INTERFACE.STRINGIO ( DATA_LINE , CURSOR_ADDRESS'(READ_WITH_ADDRESS), ROW_NO( 24 ) , COL_NO( 1 ) ) ; if DATA_LINE /= BLANK_PROLOGUE_LINE then PROLOGUE(PROLOGUE_NODE).DATA(I) := DATA_LINE ; end if ; VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; end loop ; exception when others => -- continue with the old parent DISPLAY_ERROR(" PROGRAM ERROR -- in MODIFY_PROLOGUE") ; raise ; end MODIFY_PROLOGUE ; procedure MODIFY_CALL_STAT ( START_NODE : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) is -- ========================================================= -- This procedure performs operations required to implement -- a modify param status -- ========================================================= GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE := NULL_POINTER ; LINE_NODE_ONE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE := NULL_POINTER ; CALL_STATUS : COMMAND_TYPE ; OLD_CALL_STATUS, NEW_CALL_STATUS : CALL_CONNECTION_TYPE ; LIST_PTR : TREE_DATA.LIST_NODE_ACCESS_TYPE ; LINE_TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; END_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; END_POINT : GRAPHICS_DATA.POINT ; ERROR_CALL_STATUS : EXCEPTION ; begin -- set graph window active. GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- determine the line ending scope LIST_PTR := GET_LIST_HEAD(START_NODE, CALLEE_LIST ) ; if LIST_PTR = NULL_POINTER then -- error, no line exist DISPLAY_ERROR ( "invalid, no line exists" ) ; raise ERROR_CALL_STATUS ; end if ; if LIST(LIST_PTR).NEXT /= NULL_POINTER then -- more than one line, get ending point -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; REQUEST_POINT ("enter within callee scope for status to be modified", END_POINT , END_NODE ) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- scan callee list to match end parent loop LINE_TREE_NODE := LIST(LIST_PTR).ITEM ; exit when TREE(LINE_TREE_NODE).CONNECTEE = END_NODE ; LIST_PTR := LIST(LIST_PTR).NEXT ; if LIST_PTR = NULL_POINTER then -- error, no matching line exists DISPLAY_ERROR ( "invalid, no line exists for call status modification " ) ; raise ERROR_CALL_STATUS ; end if ; end loop ; else END_NODE := TREE(LIST(LIST_PTR).ITEM).CONNECTEE ; end if ; LINE_TREE_NODE := LIST(LIST_PTR).ITEM ; -- highlite the line just for clarity PERFORM_GRAPH_TREE_OP ( LINE_TREE_NODE, HILITED ) ; -- Prompt the operator for the status. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "Select desired call status, BACKUP=no chng" , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; -- perform a modify operation on call status CALL_STATUS := CONTROL_CALL_STATUS_MENU ; -- set graph window active. GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; OLD_CALL_STATUS := TREE( LINE_TREE_NODE ).CALL_VARIETY ; NEW_CALL_STATUS := OLD_CALL_STATUS ; if CALL_STATUS = UNCONDITIONAL_CMD then NEW_CALL_STATUS := NORMAL ; elsif CALL_STATUS = TIMED_CMD then NEW_CALL_STATUS := TIMED ; elsif CALL_STATUS = CONDITIONAL_CMD then NEW_CALL_STATUS := CONDITIONAL ; end if ; if NEW_CALL_STATUS /= OLD_CALL_STATUS then -- if timed call, then check for validity if CALL_STATUS = TIMED_CMD then case TREE(END_NODE).NODE_TYPE is when TYPE_PROCEDURE | TYPE_FUNCTION | IMPORTED_PROCEDURE | IMPORTED_FUNCTION | EXPORTED_PROCEDURE | EXPORTED_FUNCTION => DISPLAY_ERROR ( "invalid, subprogram call status cannot be timed" ) ; -- restore to not highlited PERFORM_GRAPH_TREE_OP ( LINE_TREE_NODE, RESTORED ) ; raise ERROR_CALL_STATUS ; when others => null ; end case ; end if ; -- restore to not highlited PERFORM_GRAPH_TREE_OP ( LINE_TREE_NODE, RESTORED ) ; -- locate the label marking LINE_NODE_ONE := TREE( LINE_TREE_NODE ).LINE(1) ; -- now delete the old marking if OLD_CALL_STATUS /= NORMAL then GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(LINE_NODE_ONE).DATA.LABEL_SEG_ID ) ; GRAPH(LINE_NODE_ONE).DATA.LABEL_SEG_ID := NULL_SEGMENT ; end if ; -- assign the new call status TREE(LINE_TREE_NODE).CALL_VARIETY := NEW_CALL_STATUS ; -- display call marking and assign the new segment id into the tree LABEL_CALL_MARKING( LINE_TREE_NODE ) ; else -- no change in marking -- restore to not highlited PERFORM_GRAPH_TREE_OP ( LINE_TREE_NODE, RESTORED ) ; end if ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; exception when HANDLE_ABORT_BACKUP => -- set graph window active. GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- execption used to return to backup PERFORM_GRAPH_TREE_OP ( LINE_TREE_NODE, RESTORED ) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when ERROR_CALL_STATUS => -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when OPERATION_ABORTED_BY_OPERATOR => -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in MODIFY_CALL_STAT") ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; end MODIFY_CALL_STAT ; procedure MODIFY_SUBPROGRAM_PARAM_STAT ( TREE_NODE : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) is -- ========================================================= -- This procedure performs operations required to implement -- a modify param status -- ========================================================= PARENT_ENTITY : GRAPHICS_DATA.GRAPHIC_ENTITY := PACKAGE_FIGURE ; GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE := NULL_POINTER ; LABEL_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; SIZE_POINT : GRAPHICS_DATA.POINT ; LABEL_POINT : GRAPHICS_DATA.POINT ; PARAM_STATUS : COMMAND_TYPE ; OLD_NODE_STATUS : BOOLEAN ; REFERENCE_POINT : GRAPHICS_DATA.POINT ; COLOR : GRAPHICS_DATA.COLOR_TYPE ; begin -- Prompt the operator for the status. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "Select desired parameter status, BACKUP=no chng" , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; -- perform a modify operation on parameter status -- set graphic window active PARAM_STATUS := CONTROL_PARAMETER_STATUS_MENU ; -- set graph window active GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; OLD_NODE_STATUS := TREE( TREE_NODE ).HAS_PARAMETERS ; if PARAM_STATUS = HAS_PARAMETERS_CMD then TREE( TREE_NODE ).HAS_PARAMETERS := TRUE ; elsif PARAM_STATUS = NO_PARAMETERS_CMD then TREE( TREE_NODE ).HAS_PARAMETERS := FALSE ; end if ; -- if the status has changed, then redisplay the name if TREE( TREE_NODE ).HAS_PARAMETERS xor OLD_NODE_STATUS then -- determine color for display PARENT_ENTITY := GET_FIGURE_TYPE ( TREE(TREE_NODE).NODE_TYPE ) ; COLOR := ENTITY_COLOR (PARENT_ENTITY) ; GRAPH_NODE := TREE( TREE_NODE ).GRAPH_DATA ; -- now delete the old label GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID ) ; -- display the new name and get the new segment id LABEL ( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION (GRAPH_NODE) , GET_LABEL_STRING (TREE_NODE) , COLOR ) ; -- assign the new segment id into the tree GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; end if ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; exception when HANDLE_ABORT_BACKUP => -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- execption used to return to backup GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in MODIFY_SUBPROGRAM_PARAM_STAT") ; end MODIFY_SUBPROGRAM_PARAM_STAT ; procedure MODIFY_ENTRY_PARAM_STAT ( TREE_NODE : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) is -- ========================================================= -- This procedure performs operations required to implement -- a modify param status -- ========================================================= PARENT_ENTITY : GRAPHICS_DATA.GRAPHIC_ENTITY := PACKAGE_FIGURE ; GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE := NULL_POINTER ; LABEL_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; SIZE_POINT : GRAPHICS_DATA.POINT ; LABEL_POINT : GRAPHICS_DATA.POINT ; PARAM_STATUS : COMMAND_TYPE ; OLD_NODE_STATUS : BOOLEAN ; REFERENCE_POINT : GRAPHICS_DATA.POINT ; COLOR : GRAPHICS_DATA.COLOR_TYPE := ENTITY_COLOR (TASK_FIGURE) ; begin -- Prompt the operator for the status. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "Select desired parameter status, BACKUP=no chng" , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; -- perform a modify operation on parameter status -- set graphic window active PARAM_STATUS := CONTROL_PARAMETER_STATUS_MENU ; -- set graph window active GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; OLD_NODE_STATUS := TREE( TREE_NODE ).WITH_PARAMETERS ; if PARAM_STATUS = HAS_PARAMETERS_CMD then TREE( TREE_NODE ).WITH_PARAMETERS := TRUE ; elsif PARAM_STATUS = NO_PARAMETERS_CMD then TREE( TREE_NODE ).WITH_PARAMETERS := FALSE ; end if ; -- if the status has changed, then redisplay the name if TREE( TREE_NODE ).WITH_PARAMETERS xor OLD_NODE_STATUS then GRAPH_NODE := TREE( TREE_NODE ).GRAPH_DATA ; -- now delete the old label GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID ) ; -- display the new name and get the new segment id LABEL ( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION (GRAPH_NODE) , GET_LABEL_STRING (TREE_NODE) , COLOR ) ; -- assign the new segment id into the tree GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; end if ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; exception when HANDLE_ABORT_BACKUP => -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- execption used to return to backup GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in MODIFY_ENTRY_PARAM_STAT") ; end MODIFY_ENTRY_PARAM_STAT ; procedure MODIFY_ENTRY_STAT ( TREE_NODE : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) is -- ========================================================= -- This procedure performs operations required to implement -- a modify entry status -- ========================================================= GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE := NULL_POINTER ; LABEL_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; SIZE_POINT : GRAPHICS_DATA.POINT ; LABEL_POINT : GRAPHICS_DATA.POINT ; ENTRY_POINT_STAT : COMMAND_TYPE ; OLD_NODE_STATUS : BOOLEAN ; COLOR : GRAPHICS_DATA.COLOR_TYPE := ENTITY_COLOR (TASK_FIGURE) ; begin -- Prompt the operator for the status. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "Select desired entry point status, BACKUP=no chng" , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; -- perform a modify operation on entry point status ENTRY_POINT_STAT := CONTROL_ENTRY_POINT_STATUS_MENU ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; OLD_NODE_STATUS := TREE( TREE_NODE ).IS_GUARDED ; if ENTRY_POINT_STAT = GUARDED_CMD then TREE( TREE_NODE ).IS_GUARDED := TRUE ; elsif ENTRY_POINT_STAT = UNGUARDED_CMD then TREE( TREE_NODE ).IS_GUARDED := FALSE ; end if ; -- if the status has changed, then redisplay the name if TREE( TREE_NODE ).IS_GUARDED xor OLD_NODE_STATUS then GRAPH_NODE := TREE( TREE_NODE ).GRAPH_DATA ; -- now delete the old label GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID ) ; -- display the new name and get the new segment id LABEL ( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION (GRAPH_NODE) , GET_LABEL_STRING (TREE_NODE) , COLOR ) ; -- assign the new segment id into the tree GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; GRAPH(GRAPH_NODE).DATA.SIZE := SIZE_POINT ; end if ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; exception when HANDLE_ABORT_BACKUP => -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- execption used to return to backup GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in MODIFY_ENTRY_STAT") ; end MODIFY_ENTRY_STAT ; procedure MODIFY_GENERIC_NAME ( TREE_NODE : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) is -- ========================================================= -- This procedure performs operations required to implement -- a modify generic name -- ========================================================= ENTITY_NAME : TREE_DATA.NAME_TYPE := TREE_DATA.NULL_NAME ; BLANK_NAME : TREE_DATA.NAME_TYPE := TREE_DATA.NULL_NAME ; PARENT_ENTITY : GRAPHICS_DATA.GRAPHIC_ENTITY := PACKAGE_FIGURE ; GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE := NULL_POINTER ; LABEL_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; SIZE_POINT : GRAPHICS_DATA.POINT ; COLOR : GRAPHICS_DATA.COLOR_TYPE ; begin -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; if TREE( TREE_NODE ).GENERIC_STATUS = GENERIC_INSTANTIATION then -- perform a modify operation GRAPH_NODE := TREE(TREE_NODE).GRAPH_DATA ; -- highlight the generic name GRAPHIC_DRIVER.HILITE_SEGMENT ( GRAPH(GRAPH_NODE).DATA.LABEL2_SEG_ID, GKS_SPECIFICATION.HIGHLIGHTED ); -- modify the name -- prompt user for name, a blank name is an abort -- functions can be overloaded if TREE( TREE_NODE ).NODE_TYPE = TYPE_FUNCTION then REQUEST_LABEL ( ENTITY_NAME, TRUE, TRUE ) ; else REQUEST_LABEL ( ENTITY_NAME, TRUE ) ; end if ; if ENTITY_NAME /= BLANK_NAME then -- determine color for display PARENT_ENTITY := GET_FIGURE_TYPE ( TREE(TREE_NODE).NODE_TYPE ) ; COLOR := ENTITY_COLOR (PARENT_ENTITY) ; -- now delete the old label GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(GRAPH_NODE).DATA.LABEL2_SEG_ID ) ; -- store the new name TREE(TREE_NODE).CU_INSTANTIATED := ENTITY_NAME ; -- display the new name and get the new segment id and size point LABEL ( LABEL_SEGMENT , SIZE_POINT , GET_GENERIC_OFFSET_LOCATION (GRAPH_NODE) , GET_GENERIC_LABEL_STRING (TREE_NODE) , COLOR ) ; -- place the graph information in the graph node GRAPH(GRAPH_NODE).DATA.LABEL2_SEG_ID := LABEL_SEGMENT ; else -- the modify was abort since new label is blank -- restore to not highlited GRAPHIC_DRIVER.HILITE_SEGMENT ( GRAPH(GRAPH_NODE).DATA.LABEL2_SEG_ID, GKS_SPECIFICATION.NORMAL ); end if ; end if ; -- is a generic_instantiation -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; exception when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in MODIFY_GENERIC_NAME ") ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; end MODIFY_GENERIC_NAME ; procedure MODIFY_NAME ( TREE_NODE : in TREE_DATA.TREE_NODE_ACCESS_TYPE ) is -- ========================================================= -- This procedure performs operations required to implement -- a modify name -- ========================================================= BLANK_LINE : constant string := " " ; ENTITY_NAME : TREE_DATA.NAME_TYPE := TREE_DATA.NULL_NAME ; BLANK_NAME : TREE_DATA.NAME_TYPE := TREE_DATA.NULL_NAME ; SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; PARENT_ENTITY : GRAPHICS_DATA.GRAPHIC_ENTITY := PACKAGE_FIGURE ; GRAPH_NODE : TREE_DATA.GRAPH_NODE_ACCESS_TYPE := NULL_POINTER ; LINE_NODE : TREE_DATA.POINTS := NULL_POINTER ; LABEL_SEGMENT : GKS_SPECIFICATION.SEGMENT_NAME ; REFERENCE_SEG_ID : GKS_SPECIFICATION.SEGMENT_NAME ; SIZE_POINT : GRAPHICS_DATA.POINT ; LABEL_POINT : GRAPHICS_DATA.POINT ; REFERENCE_POINT : GRAPHICS_DATA.POINT ; COLOR : GRAPHICS_DATA.COLOR_TYPE ; ERROR_ON_MODIFY_CHOICE : exception ; begin -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- perform a modify operation -- set graphic window active GRAPH_NODE := TREE(TREE_NODE).GRAPH_DATA ; -- highlight the annotation GRAPHIC_DRIVER.HILITE_SEGMENT ( GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID, GKS_SPECIFICATION.HIGHLIGHTED ); -- modify the name -- prompt user for name, a blank name is an abort -- functions can be overloaded if TREE( TREE_NODE ).NODE_TYPE = TYPE_FUNCTION or else TREE( TREE_NODE ).NODE_TYPE = EXPORTED_FUNCTION or else TREE( TREE_NODE ).NODE_TYPE = IMPORTED_FUNCTION then REQUEST_LABEL ( ENTITY_NAME, TRUE, TRUE ) ; else REQUEST_LABEL ( ENTITY_NAME, TRUE ) ; end if ; if ENTITY_NAME /= BLANK_NAME then -- determine color for display case TREE(TREE_NODE).NODE_TYPE is when TYPE_ENTRY_POINT | IMPORTED_VIRTUAL_PACKAGE .. EXPORTED_EXCEPTION => PARENT_ENTITY := GET_FIGURE_TYPE ( TREE(TREE(TREE_NODE).PARENT).NODE_TYPE ) ; when others => PARENT_ENTITY := GET_FIGURE_TYPE ( TREE(TREE_NODE).NODE_TYPE ) ; end case ; COLOR := ENTITY_COLOR (PARENT_ENTITY) ; -- now delete the old label GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID ) ; -- store the new name TREE(TREE_NODE).NAME := ENTITY_NAME ; -- display the new name and get the new segment id and size point LABEL ( LABEL_SEGMENT , SIZE_POINT , GET_OFFSET_LOCATION (GRAPH_NODE) , GET_LABEL_STRING (TREE_NODE) , COLOR ) ; -- check if the size point and line connect needs to be moved case TREE(TREE_NODE).NODE_TYPE is when EXPORTED_PROCEDURE | EXPORTED_FUNCTION | EXPORTED_ENTRY_POINT | EXPORTED_TYPE | EXPORTED_OBJECT | EXPORTED_EXCEPTION => if SIZE_POINT /= GRAPH(GRAPH_NODE).DATA.SIZE then GRAPH(GRAPH_NODE).DATA.SIZE := SIZE_POINT ; LINE_NODE := TREE(TREE_NODE).LINE(1) ; -- check for outgoing line if LINE_NODE /= NULL_POINTER then -- now delete the old line segement GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(LINE_NODE).DATA.SEGMENT_ID ) ; GRAPH(LINE_NODE).DATA.LOCATION := SIZE_POINT ; GRAPH(LINE_NODE).DATA.SEGMENT_ID := DRAW_LINE (EXPORT_CONNECT_LINE , GRAPH(LINE_NODE).DATA.LOCATION, GRAPH(TREE(TREE_NODE).LINE(2)).DATA.LOCATION ) ; end if ; end if ; when others => null ; end case ; -- place the graph information in the graph node GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID := LABEL_SEGMENT ; else -- the modify was abort since new label is blank -- restore to not highlited GRAPHIC_DRIVER.HILITE_SEGMENT ( GRAPH(GRAPH_NODE).DATA.LABEL_SEG_ID, GKS_SPECIFICATION.NORMAL ); end if ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; exception when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in MODIFY_NAME ") ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; end MODIFY_NAME ; function LONGEST_LABEL_OK ( TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE ; LABEL_CREATE : LABEL_CREATE_TYPE ) return Boolean is -- ========================================================= -- This procedure performs operations required to implement -- an overlap check if the modified name is extended. -- Returns true if extending is ok. -- ========================================================= PARENT, PARENTS_PARENT : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; UPPER_RIGHT_POINT, LOWER_RIGHT_POINT : GRAPHICS_DATA.POINT ; PROPER_SCOPE : Boolean ; begin -- check right side points, since only they could become invalid UPPER_RIGHT_POINT.X := GRAPH( TREE( TREE_NODE ).GRAPH_DATA ).DATA.LOCATION.X + GRAPHICS_DATA.LABEL_MAX_LENGTH + ( 2 * GRAPHICS_DATA.CHARACTER_WIDTH_OFFSET ) ; UPPER_RIGHT_POINT.Y := GRAPH( TREE( TREE_NODE ).GRAPH_DATA ).DATA.LOCATION.Y ; LOWER_RIGHT_POINT.X := UPPER_RIGHT_POINT.X ; LOWER_RIGHT_POINT.Y := GRAPH( TREE( TREE_NODE ).GRAPH_DATA ).DATA.SIZE.Y ; -- get the parent entity for comparision PARENT := TREE( TREE_NODE ).PARENT ; PARENTS_PARENT := TREE( PARENT ).PARENT ; if LABEL_CREATE = LABEL_IMPORT then -- for imports, the size points are within the parent's parent. PROPER_SCOPE := ( PARENTS_PARENT = SCOPE_SEARCH ( UPPER_RIGHT_POINT )) and ( PARENTS_PARENT = SCOPE_SEARCH ( LOWER_RIGHT_POINT )) ; else -- for exports, the size points are within the parent. PROPER_SCOPE := ( PARENT = SCOPE_SEARCH ( UPPER_RIGHT_POINT )) and ( PARENT = SCOPE_SEARCH ( LOWER_RIGHT_POINT )) ; end if ; if not PROPER_SCOPE then DISPLAY_ERROR ("if modified the annotation may show improper scope" & " (overlap or overextend)" ) ; return false ; else return true ; end if ; end LONGEST_LABEL_OK ; procedure MODIFY is -- ========================================================= -- This procedure performs operations required to implement -- a modify -- ========================================================= TREE_NODE : TREE_DATA.TREE_NODE_ACCESS_TYPE := NULL_POINTER ; REFERENCE_POINT : GRAPHICS_DATA.POINT ; ERROR_ON_MODIFY_CHOICE : exception ; begin -- perform a modify operation -- set graphic window active GRAPHIC_DRIVER.SELECT_WINDOW( GRAPH_VIEW_PORT ) ; -- turn on the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.ON ) ; -- determine the tree node needing modification REQUEST_POINT ( "select scope of entity needing modification " , REFERENCE_POINT , TREE_NODE ) ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; case TREE(TREE_NODE).NODE_TYPE is when ROOT => raise ERROR_ON_MODIFY_CHOICE ; when TYPE_VIRTUAL_PACKAGE | TYPE_TASK => -- Assure that the entire subtree is visible on the view window. VIEW_WINDOW_CHECK( TREE_NODE ) ; -- perform modify MODIFY_NAME( TREE_NODE ) ; MODIFY_PROLOGUE( TREE_NODE ) ; when TYPE_PACKAGE => -- Assure that the entire subtree is visible on the view window. VIEW_WINDOW_CHECK( TREE_NODE ) ; -- perform modify MODIFY_NAME( TREE_NODE ) ; MODIFY_GENERIC_NAME( TREE_NODE ) ; MODIFY_PROLOGUE( TREE_NODE ) ; when TYPE_PROCEDURE | TYPE_FUNCTION => -- Assure that the entire subtree is visible on the view window. VIEW_WINDOW_CHECK( TREE_NODE ) ; -- perform modify MODIFY_NAME( TREE_NODE ) ; MODIFY_SUBPROGRAM_PARAM_STAT( TREE_NODE ) ; MODIFY_GENERIC_NAME( TREE_NODE ) ; MODIFY_PROLOGUE( TREE_NODE ) ; when TYPE_ENTRY_POINT => -- Assure that the entire subtree is visible on the view window. VIEW_WINDOW_CHECK( TREE_NODE ) ; -- Assure that extending the label is ok if LONGEST_LABEL_OK ( TREE_NODE, LABEL_EXPORT ) then -- perform modify MODIFY_NAME( TREE_NODE ) ; MODIFY_ENTRY_STAT( TREE_NODE ) ; MODIFY_ENTRY_PARAM_STAT( TREE_NODE ) ; end if ; when TYPE_BODY => -- Assure that the entire subtree is visible on the view window. VIEW_WINDOW_CHECK( TREE_NODE ) ; -- perform modify MODIFY_CALL_STAT( TREE_NODE ) ; when IMPORTED_VIRTUAL_PACKAGE..IMPORTED_FUNCTION => -- Assure that the entire subtree is visible on the view window. VIEW_WINDOW_CHECK( TREE_NODE ) ; -- Assure that extending the label is ok if LONGEST_LABEL_OK ( TREE_NODE, LABEL_IMPORT ) then -- perform modify MODIFY_NAME( TREE_NODE ) ; end if ; when EXPORTED_PROCEDURE..EXPORTED_EXCEPTION => -- Assure that the entire subtree is visible on the view window. VIEW_WINDOW_CHECK( TREE_NODE ) ; -- Assure that extending the label is ok if LONGEST_LABEL_OK ( TREE_NODE, LABEL_EXPORT ) then -- perform modify MODIFY_NAME( TREE_NODE ) ; end if ; when others => raise ERROR_ON_MODIFY_CHOICE ; end case ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; exception when ERROR_ON_MODIFY_CHOICE => DISPLAY_ERROR( "entity selected can not be modified" ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when OPERATION_ABORTED_BY_OPERATOR => -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in MODIFY ") ; -- turn off the abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF ) ; -- set menu window active GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; end MODIFY ; procedure CONTROL_DESIGN_MENU is -- ========================================================= -- This procedure performs operations required to implement -- the design menu commands. -- ========================================================= COMMAND : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DONE : BOOLEAN := FALSE ; DUMMY : COMMAND_TYPE ; subtype CREATE_CMD is COMMAND_TYPE range VIRT_PACKAGE_CMD .. ANNOTATION_CMD ; subtype CREATE_CONNECTION_CMD is COMMAND_TYPE range CALL_CONNECT_CMD .. EXPORT_CONNECT_CMD ; begin -- pre place icon cursor on virtual package COMMAND := VIRT_PACKAGE_CMD ; while not DONE loop begin -- display the current menu and get command from GRAPHICS_DRIVER DISPLAY_MENU_AND_GET_COMMAND ( MENU_ID'( DESIGN_MENU ) , COMMAND ) ; case COMMAND is -- implement the main menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( DESIGN_MENU ) ) ; when BACKUP_CMD => -- return to the MAIN_MENU DONE := true ; -- exit the loop when PAN_ZOOM_CMD => -- go process pan zoom operation, return to here DUMMY := CONTROL_PAN_ZOOM_MENU ; when CREATE_CMD => -- perform a create CREATE( COMMAND ) ; when CREATE_CONNECTION_CMD => -- perform a create connection CREATE_CONNECTION( COMMAND ) ; when DELETE_CONNECT_CMD => -- perform a delete connection DELETE_CONNECTION ; when DELETE_CMD => -- perform a delete DELETE ; when RESIZE_CMD => -- perform the resize MOVE_AND_RESIZE ; when MOVE_CMD => -- perform a move of an object MOVE_AND_RESIZE ; when MODIFY_CMD => -- perform an edit MODIFY ; when others => -- this should not occur null ; end case ; -- COMMAND exception when HANDLE_RESTART => -- exception used to return to the main menu raise ; when OPERATION_ABORTED_BY_OPERATOR => -- turn off abort icon GRAPHIC_DRIVER.SET_ABORT_CAPABILITY( GRAPHICS_DATA.OFF); -- clear the alpha screen VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in DESIGN Menu control ") ; -- set menu window active. GRAPHIC_DRIVER.SELECT_WINDOW( MENU_VIEW_PORT ) ; end ; end loop ; end CONTROL_DESIGN_MENU ; end MMI_DESIGN ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --mmi_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 85-08-28 12:47 by RAM with SYSTEM ; package MMI is -- ============================================================== -- -- This package provides the Man-Machine Interface and -- implements the requested graphics operations for -- the SKETCHER program. It inputs the commands from -- the user via the GRAPHICS_DRIVER to isolate it from -- device dependencies. The decoded commands are then -- passed to the appropriate routine(s) of the MMI_OPERATIONS -- package body. -- -- Requirements: -- 1) decode commands entered by the user. -- 2) implement the commands required in the SKETCHER -- User Manual. -- -- =============================================================== procedure INITIALIZE ; -- ======================================================== -- This procedure will initialize the command derefencing -- table and download all terminal dependent command -- data. -- ======================================================== procedure PROCESS_COMMAND ; -- ====================================================== -- -- This procedure will input commands from the user -- via the GRAPHICS_DRIVER. The selected commands are -- then passed to the MMI_OPERATIONS package. -- ======================================================= procedure PANIC_EXIT ; -- ======================================================== -- This procedure orchestrates an abnormal termination -- condition detected by the program unit. -- ======================================================== end MMI ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --mmi_body.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-02-10 09:30 BY RAM with MMI_PARAMETERS ; use MMI_PARAMETERS ; with MMI_CONTROL_MENUS ; with MMI_DESIGN ; with MMI_ATTRIBUTES ; with VIRTUAL_TERMINAL_INTERFACE ; use VIRTUAL_TERMINAL_INTERFACE ; with GKS_SPECIFICATION ; use GKS_SPECIFICATION ; with GRAPHICS_DATA ; use GRAPHICS_DATA ; with GRAPHIC_DRIVER ; use GRAPHIC_DRIVER ; with PDL_GEN ; with TRACE_PKG ; use TRACE_PKG ; with TREE_DATA ; use TREE_DATA ; with TREE_OPS ; use TREE_OPS ; with TREE_IO ; use TREE_IO ; with TEXT_IO ; with UTILITIES ; use UTILITIES ; with UTIL_FOR_TREE ; use UTIL_FOR_TREE ; package body MMI is -- =========================================================== -- -- This package provides the Man-Machine Interface for -- the SKETCHER program. It inputs the commands from -- the user via the GRAPHICS_DRIVER to isolate it from -- device dependencies. The decoded commands are then -- passed to the appropriate routine(s). -- -- Requirements: -- 1) decode commands entered by the user. -- 2) implement the commands required in the SKETCHER -- User Manual. -- -- =========================================================== package GRAPHICS renames GRAPHICS_DATA ; procedure INITIALIZE is -- ========================================================= -- This procedure will initialize the command derefencing -- table and download all terminal dependent command -- data. -- The terminal will involve downloading -- a segment for each menu item, and setting up the -- COMMAND_SEGMENT_OBJECT_CROSS_REFERENCE_TABLE to translate -- a segment into a command. -- =========================================================== DEFAULT_SCREEN_COLOR : constant COLOR_TYPE := WHITE ; MENU_WINDOW : constant GRAPHICS_DATA.WINDOW_TYPE := GRAPHICS_DATA.WINDOW_TYPE'( MENU_VIEW_PORT ) ; GRAPHIC_WINDOW : constant GRAPHICS_DATA.WINDOW_TYPE := GRAPHICS_DATA.WINDOW_TYPE'( GRAPH_VIEW_PORT ) ; INITIAL_MSG : constant STRING := " PROGRAM INITIALIZATION " ; SIZE_DUMMY , ICON_LOCATION , FRAME_UPPER_LEFT , FRAME_LOWER_RIGHT : GRAPHICS_DATA.POINT ; BORDER_WIDTH : constant GRAPHICS_DATA.WC := 100 ; ICON_X_OFFSET : constant GRAPHICS_DATA.WC := 100 ; ICON_Y_OFFSET : constant GRAPHICS_DATA.WC := 200 ; FRAME_OFFSET : constant GRAPHICS_DATA.WC := 30 ; ICON_WIDTH , ICON_HEIGHT , ICON_Y_FRAME_SIZE : GRAPHICS_DATA.WC ; MENU_AREA : GRAPHICS_DATA.RECTANGLE ; FRAME_COLOR : constant GRAPHICS_DATA.COLOR_TYPE := BLACK ; ICON_COLOR : GRAPHICS_DATA.COLOR_TYPE := BLACK ; LABEL_COLOR : constant GRAPHICS_DATA.COLOR_TYPE := GREEN ; BACK_COLOR : GRAPHICS_DATA.COLOR_TYPE := YELLOW ; FRAME_LINE : constant GRAPHICS_DATA.LINE_TYPE := SOLID ; FRAME_FILL : GKS_SPECIFICATION.INTERIOR_STYLE := GKS_SPECIFICATION.HOLLOW ; SEGMENT_ID : GKS_SPECIFICATION.SEGMENT_NAME ; ICON_NUMBER : ICON_ID ; COLOR_CMD : COMMAND_TYPE ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "MMI.INIT" ) ; end if ; -- Initialize terminal for VT100 operation VIRTUAL_TERMINAL_INTERFACE.VTI_INIT ; UTILITIES.SIGN_ON ; -- Initialize Terminal for Graphics GRAPHIC_DRIVER.INITIALIZE_GRAPHICS_MODE ; GRAPHIC_DRIVER.INIT_SCREEN ( DEFAULT_SCREEN_COLOR , MENU_AREA ) ; -- Save menu minimum and maximum x values. MENU_X_MIN := MENU_AREA.X.MIN ; MENU_X_MAX := MENU_AREA.X.MAX ; -- Display program initialization message VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( LOW_LEVEL_CRT_FUNCTIONS'( BLINK_CHARS )) ; VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( LOW_LEVEL_CRT_FUNCTIONS'( NEGATIVE_CHARS )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( INITIAL_MSG , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 )); VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( LOW_LEVEL_CRT_FUNCTIONS'( CLEAR_ATTRIBUTES )) ; -- build and initialize menus -- select menu window GRAPHIC_DRIVER.SELECT_WINDOW ( MENU_WINDOW ) ; -- define locations for icon frames ICON_Y_FRAME_SIZE := ( MENU_AREA.Y.MAX - MENU_AREA.Y.MIN ) / ( ICON_BOUNDARY'last - ICON_BOUNDARY'first + 1 ) ; for ICON_NUMBER in ICON_BOUNDARY'range(1) loop ICON_BOUNDARY( ICON_NUMBER ).LOWER := MENU_AREA.Y.MAX - ( ICON_NUMBER * ICON_Y_FRAME_SIZE ) ; ICON_BOUNDARY( ICON_NUMBER ).UPPER := ICON_BOUNDARY( ICON_NUMBER ).LOWER + ICON_Y_FRAME_SIZE ; end loop ; -- define locations for icon backlites ICON_HEIGHT := ICON_Y_FRAME_SIZE - ( 2 * BORDER_WIDTH ) ; ICON_WIDTH := ( MENU_AREA.X.MAX - MENU_AREA.X.MIN ) - ( 2 * BORDER_WIDTH ) ; -- draw in decreasing priority GRAPHIC_DRIVER.SET_DRAWING_PRIORITY( 1.0 ) ; -- draw frames FRAME_UPPER_LEFT.X := MENU_AREA.X.MIN ; FRAME_LOWER_RIGHT.X := MENU_AREA.X.MAX - FRAME_OFFSET ; for ICON_NUMBER in ICON_BOUNDARY'range(1) loop FRAME_LOWER_RIGHT.Y := ICON_BOUNDARY ( ICON_NUMBER ).LOWER ; FRAME_UPPER_LEFT.Y := FRAME_LOWER_RIGHT.Y + ICON_Y_FRAME_SIZE ; if ICON_NUMBER /= ICON_BOUNDARY'first(1) then SEGMENT_ID := GRAPHIC_DRIVER.DRAW_BOX ( FRAME_COLOR , FRAME_FILL , FRAME_LINE , FRAME_UPPER_LEFT , FRAME_LOWER_RIGHT ) ; end if ; end loop ; -- draw color icon squares FRAME_FILL := GKS_SPECIFICATION.SOLID ; FRAME_UPPER_LEFT.X := MENU_AREA.X.MIN + FRAME_OFFSET + 3 *( ( MENU_AREA.X.MAX - MENU_AREA.X.MIN ) / 4 ) ; FRAME_LOWER_RIGHT.X := MENU_AREA.X.MAX - 2 * FRAME_OFFSET ; for ICON_NUMBER in ICON_ID'First..ICON_ID'Last loop FRAME_LOWER_RIGHT.Y := ICON_BOUNDARY ( ICON_NUMBER ).LOWER + FRAME_OFFSET ; FRAME_UPPER_LEFT.Y := FRAME_LOWER_RIGHT.Y + ICON_Y_FRAME_SIZE - 2 * FRAME_OFFSET ; COLOR_CMD := MENU_TABLE( COLOR_LINE_MENU, ICON_NUMBER ).COMMAND ; case COLOR_CMD is when GREEN_CMD => ICON_COLOR := GREEN ; when BLUE_CMD => ICON_COLOR := BLUE ; when VIOLET_CMD => ICON_COLOR := VIOLET ; when RED_CMD => ICON_COLOR := RED ; when ORANGE_CMD => ICON_COLOR := ORANGE ; when YELLOW_CMD => ICON_COLOR := YELLOW ; when BLACK_CMD => ICON_COLOR := BLACK ; when others => null ; end case ; -- COLOR_CMD if COLOR_CMD in GREEN_CMD..BLACK_CMD then ICON_COLOR_SEGMENTS( COMMAND_TYPE'Pos( COLOR_CMD ) ) := GRAPHIC_DRIVER.DRAW_BOX ( ICON_COLOR , FRAME_FILL , FRAME_LINE , FRAME_UPPER_LEFT , FRAME_LOWER_RIGHT ) ; end if ; end loop ; -- clear color icons from menu window GRAPHIC_DRIVER.CLEAR_MENU( ICON_COLOR_SEGMENTS ) ; FRAME_FILL := GKS_SPECIFICATION.HOLLOW ; -- set up character parameters SET_CHARACTER_SIZE_ATTRIBUTES ( GRAPHICS_DATA.DEFAULT_CHARACTER_HEIGHT, GRAPHICS_DATA.DEFAULT_CHARACTER_WIDTH, GRAPHICS_DATA.DEFAULT_CHARACTER_WIDTH_SPACING, GKS_SPECIFICATION.CHAR_PRECISION ) ; -- draw icons ICON_LOCATION.X := MENU_AREA.X.MIN + ICON_X_OFFSET ; for MENU in MENU_TABLE'range(1) loop for ICON in MENU_TABLE'range(2) loop if MENU_TABLE ( MENU , ICON ).COMMAND /= NULL_CMD then if MENU_TABLE ( MENU , ICON ).COMMAND = MENU_LABEL then ICON_COLOR := LABEL_COLOR ; BACK_COLOR := WHITE ; else ICON_COLOR := BLACK ; BACK_COLOR := YELLOW ; end if ; ICON_LOCATION.Y := ICON_BOUNDARY ( ICON ).LOWER + ICON_Y_OFFSET ; GRAPHIC_DRIVER.LABEL( ICON_SEGMENTS( MENU )( ICON ) , SIZE_DUMMY , ICON_LOCATION , MENU_TABLE ( MENU , ICON ).NAME , ICON_COLOR, BACK_COLOR ) ; end if ; end loop ; -- inner loop -- clear menu from menu window GRAPHIC_DRIVER.CLEAR_MENU ( ICON_SEGMENTS ( MENU ) ) ; end loop ; -- outer loop GRAPHIC_DRIVER.SET_DRAWING_PRIORITY( 0.95 ) ; GRAPHIC_DRIVER.GRAPHICS_SCREEN ( GRAPHICS_DATA.MODE_TYPE'( ON ) ) ; if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "MMI.INIT end procedure" ) ; end if ; end INITIALIZE ; procedure PROCESS_COMMAND is -- ========================================================= -- This procedure will input commands from the user -- and implement the MAIN_MENU. The implementation -- of lower level menu commands are handled by lower -- level procedures. -- ========================================================== COMMAND : COMMAND_TYPE := COMMAND_TYPE'( FINISHED_CMD ) ; SUB_COMMAND : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; CONFIRM_STATUS : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DUMMY : COMMAND_TYPE := COMMAND_TYPE'( BACKUP_CMD ) ; DONE : BOOLEAN := FALSE ; PDL_FILENAME : TREE_IO.FILENAME_TYPE := TREE_IO.NULL_FILENAME ; SESSION_FILE : TEXT_IO.FILE_TYPE ; SESSION_FILE_NAME : TREE_IO.FILENAME_TYPE ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "MMI.PROCESS_COMMAND" ) ; end if ; while not DONE loop begin -- pre place the icon cursor on the design_cmd COMMAND := DESIGN_CMD ; -- display the current menu and get command from GRAPHICS_DRIVER DISPLAY_MENU_AND_GET_COMMAND ( MENU_ID'( MAIN_MENU ) , COMMAND ) ; case COMMAND is -- implement the main menu commands when HELP_CMD => -- display help for current menu HELP ( MENU_ID'( MAIN_MENU ) ) ; when PAN_ZOOM_CMD => -- go preform pan / zoom operations, return to here DUMMY := MMI_CONTROL_MENUS.CONTROL_PAN_ZOOM_MENU ; when DESIGN_CMD => -- display the design menu and process design commands MMI_DESIGN.CONTROL_DESIGN_MENU ; when ATTRIBUTES_CMD => -- display the attributes menu and process attribute commands MMI_ATTRIBUTES.CONTROL_ATTRIBUTES_MENU ; when GEN_PDL_CMD => begin -- set default PDL file name PDL_FILENAME := TREE_IO.DATA_FILENAME ; -- generate pdl from current file name, use package -- utilities. -- [ get the filename for output ] SUB_COMMAND := MMI_CONTROL_MENUS.CONTROL_PDL_STATUS_MENU ; if SUB_COMMAND = NO_SUPPORT_CMD then PDL_GEN.INCLUDE_SUPPORT_PACKAGE := false ; else PDL_GEN.INCLUDE_SUPPORT_PACKAGE := true ; end if ; PDL_GEN.GENERATE_PDL( PDL_FILENAME) ; exception when HANDLE_ABORT_BACKUP => null ; when others => -- this should not occur raise ; end ; when READ_FILE_CMD => -- check that deletion of current graph is ok VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "The current graph will be erased, CONFIRM erase to continue " , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; GRAPHIC_DRIVER.SELECT_WINDOW (MENU_VIEW_PORT) ; -- get response SUB_COMMAND := MMI_CONTROL_MENUS.CONTROL_DELETE_MENU ; if SUB_COMMAND = CONFIRM_CMD then -- delete the current contents of the tree GRAPHIC_DRIVER.SELECT_WINDOW (GRAPH_VIEW_PORT) ; for GPTR in 1 .. TREE_DATA.MAX_GRAPH_NODES loop if GRAPH(GPTR).OWNING_TREE_NODE /= NULL_POINTER then if GRAPH(GPTR).DATA.SEGMENT_ID /= NULL_SEGMENT then GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(GPTR).DATA.SEGMENT_ID ) ; end if ; if GRAPH(GPTR).DATA.LABEL_SEG_ID /= NULL_SEGMENT then GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(GPTR).DATA.LABEL_SEG_ID ) ; end if ; if GRAPH(GPTR).DATA.LABEL2_SEG_ID /= NULL_SEGMENT then GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(GPTR).DATA.LABEL2_SEG_ID ) ; end if ; end if ; end loop ; GRAPHIC_DRIVER.SELECT_WINDOW (MENU_VIEW_PORT) ; begin -- get new_filename SESSION_FILE_NAME := UTIL_FOR_TREE.GET_FILE_HANDLE ; -- check the filename, and if valid read in the file -- and draw the corresponding graph if SESSION_FILE_NAME /= TREE_IO.NULL_FILENAME then -- see if file currently exists, -- raises NAME_ERROR if it doesn't TEXT_IO.OPEN( SESSION_FILE , TEXT_IO.IN_FILE , TREE_IO.COMPLETE_FILE_NAME ( SESSION_FILE_NAME , TREE_IO.TREE_EXTENSION ) ) ; -- close file for tree_io.read TEXT_IO.CLOSE ( SESSION_FILE ) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "Reading from " & SESSION_FILE_NAME , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- filename used so read in to initialize the -- tree structure, writes over old TREE_IO.READ( TREE_IO.COMPLETE_FILE_NAME ( SESSION_FILE_NAME , TREE_IO.TREE_EXTENSION ) ) ; -- now draw the tree UTIL_FOR_TREE.DRAW_GRAPH_TREE ; -- set up tree file name TREE_IO.DATA_FILENAME := SESSION_FILE_NAME ; else DISPLAY_TIMED_MESSAGE( "New file " & TREE_IO.DEFAULT_FILENAME ) ; -- initialize the tree to startup condition TREE_OPS.INITIALIZE_TREE ; TREE_IO.DATA_FILENAME := TREE_IO.DEFAULT_FILENAME ; end if ; exception when TEXT_IO.NAME_ERROR => -- a new file is desired, just continue DISPLAY_TIMED_MESSAGE( "New file " & SESSION_FILE_NAME ) ; -- initialize the tree to startup condition TREE_OPS.INITIALIZE_TREE ; TREE_IO.DATA_FILENAME := SESSION_FILE_NAME ; when others => DISPLAY_ERROR (" file not available for input ") ; GRAPHIC_DRIVER.SELECT_WINDOW (MENU_VIEW_PORT) ; end ; end if ; VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; when WRITE_FILE_CMD => begin VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "If blank, the graph will be written to " & TREE_IO.DATA_FILENAME , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 22 ) ) ; -- get new_filename SESSION_FILE_NAME := UTIL_FOR_TREE.GET_FILE_HANDLE ( SUPRESS_CLEAR_SCREEN => true ) ; -- write the current graph file out to a -- file with the specified name, default to current if SESSION_FILE_NAME = TREE_IO.NULL_FILENAME then SESSION_FILE_NAME := TREE_IO.DATA_FILENAME ; end if ; DISPLAY_TIMED_MESSAGE( "Writing file " & SESSION_FILE_NAME ) ; -- attempt to write the curent GRAPH_TREE to the file TREE_IO.WRITE( TREE_IO.COMPLETE_FILE_NAME ( SESSION_FILE_NAME , TREE_IO.TREE_EXTENSION ) ) ; exception when TREE_IO.INVALID_FILE_SPECIFIER => DISPLAY_ERROR (" unable to create a file with the specified name ") ; when others => DISPLAY_ERROR (" PROGRAM ERROR -- unable to complete file output ") ; end ; VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; when PRINT_CMD => -- print current graphic screen to printer. GRAPHIC_DRIVER.PRINT_SCREEN ; when QUIT_CMD => -- request confirmation of quit CONFIRM_STATUS := MMI_CONTROL_MENUS.CONTROL_DELETE_MENU ; -- process the results of the confirmation if CONFIRM_STATUS = CONFIRM_CMD then -- exit program without saving any files. -- set terminal to standard operating mode GRAPHIC_DRIVER.TERMINATE_GRAPHICS_MODE ; DONE := true ; -- exit the loop end if ; when FINISHED_CMD => VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "Writing file " & TREE_IO.DATA_FILENAME , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 ) ) ; -- Save files under current file name and then exit program. TREE_IO.WRITE ( TREE_IO.COMPLETE_FILE_NAME ( TREE_IO.DATA_FILENAME , TREE_IO.TREE_EXTENSION ) ) ; -- set terminal to standard operating mode GRAPHIC_DRIVER.TERMINATE_GRAPHICS_MODE ; DONE := true ; -- exit the loop when others => -- this should not occur null ; end case ; -- COMMAND exception when HANDLE_RESTART => -- exception used to return to the main menu null ; when GRAPHICS_DATA.AVAILABLE_SEGMENTS_EXHAUSTED => -- This exception is raised when the segments in -- the GRAPHICS_DRIVER have been exhausted. Recovery -- is performed by restarting the drawing with -- the first segment available above those used -- for the menus. DISPLAY_ERROR (" Segment Identifier Recovery To Begin ") ; -- delete the current contents of the tree GRAPHIC_DRIVER.SELECT_WINDOW (GRAPH_VIEW_PORT) ; for GPTR in 1 .. TREE_DATA.MAX_GRAPH_NODES loop if GRAPH(GPTR).OWNING_TREE_NODE /= NULL_POINTER then if GRAPH(GPTR).DATA.SEGMENT_ID /= NULL_SEGMENT then GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(GPTR).DATA.SEGMENT_ID ) ; end if ; if GRAPH(GPTR).DATA.LABEL_SEG_ID /= NULL_SEGMENT then GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(GPTR).DATA.LABEL_SEG_ID ) ; end if ; if GRAPH(GPTR).DATA.LABEL2_SEG_ID /= NULL_SEGMENT then GRAPHIC_DRIVER.DELETE_SEGMENT ( GRAPH(GPTR).DATA.LABEL2_SEG_ID ) ; end if ; end if ; end loop ; GRAPHIC_DRIVER.SELECT_WINDOW (MENU_VIEW_PORT) ; -- now draw the tree UTIL_FOR_TREE.DRAW_GRAPH_TREE ; when others => -- handle error conditions that might occur -- report the error and continue DISPLAY_ERROR (" PROGRAM ERROR -- in process command ") ; end ; end loop ; if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "MMI.PROCESS_COMMAND end procedure" ) ; end if ; end PROCESS_COMMAND ; procedure PANIC_EXIT is -- ======================================================= -- This procedure orchestrates an abnormal termination -- condition detected by the program unit. -- ======================================================== WARNING_LINE : constant STRING := "PROGRAM ERROR -- unhandled exception propagated by the MMI " ; begin if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "MMI.PANIC_EXIT" ) ; end if ; -- set terminal to standard operating mode GRAPHIC_DRIVER.TERMINATE_GRAPHICS_MODE ; -- send message to user via alpha screen that the program has -- failed and we will try to save work in a temp file. VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( " " , FORMAT_FCT'( CLEAR_SCREEN ) , ROW_NO( 1 )) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( WARNING_LINE , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 23 )); VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( ">>>> " & TREE_IO.COMPLETE_FILE_NAME( TREE_IO.DEFAULT_FILENAME , TREE_IO.TREE_EXTENSION ) & " <<<<" , FORMAT_FCT'( CENTER_A_LINE ) , ROW_NO( 24 )); TREE_IO.WRITE( TREE_IO.COMPLETE_FILE_NAME( TREE_IO.DEFAULT_FILENAME , TREE_IO.TREE_EXTENSION ) ) ; if TRACE_PKG.REQUEST_TRACE then TRACE_PKG.TRACE ( "MMI.PANIC_EXIT end procedure" ) ; end if ; end PANIC_EXIT ; begin null; end MMI ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --gad.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 86-01-20 16:15 by JL with SYSTEM ; with MMI ; use MMI ; with UTILITIES ; use UTILITIES ; with VIRTUAL_TERMINAL_INTERFACE ; use VIRTUAL_TERMINAL_INTERFACE ; with UTIL_FOR_TREE ; use UTIL_FOR_TREE ; with TREE_IO ; use TREE_IO ; with TEXT_IO ; use TEXT_IO ; procedure GAD is -- ================================================================== -- -- This is the main procedure of GAD and it will -- control and execute the procedures and packages needed -- to operate GAD. It will control the creation and -- initialization of the graphics data file, the -- execution of the Man-Machine Interface, and top level -- error handling. -- -- Requirements: -- 1) create working file -- 2) open existing file and copy into working file, -- close when completed. -- 3) invoke MMI_OPERATIONS command processor -- 4) handle error conditions (exceptions) -- -- ================================================================== SESSION_FILE : TEXT_IO.FILE_TYPE ; SESSION_FILE_NAME : TREE_IO.FILENAME_TYPE ; begin -- set sign on display to prototype UTILITIES.PROTOTYPE_SIGN_ON := False ; -- initialize global and package specific data MMI.INITIALIZE ; -- get new_filename SESSION_FILE_NAME := UTIL_FOR_TREE.GET_FILE_HANDLE ; CHECK_FOR_OLD_SESSION_NAME : begin -- CHECK_FOR_OLD_SESSION_NAME if SESSION_FILE_NAME /= TREE_IO.NULL_FILENAME then -- see if file currently exists -- raises NAME_ERROR if it doesn't TEXT_IO.OPEN ( SESSION_FILE , TEXT_IO.IN_FILE , TREE_IO.COMPLETE_FILE_NAME( SESSION_FILE_NAME , TREE_IO.TREE_EXTENSION)); -- close file for tree_io.read TEXT_IO.CLOSE ( SESSION_FILE ) ; VIRTUAL_TERMINAL_INTERFACE.FORMAT_LINE ( "Reading from " & SESSION_FILE_NAME , FORMAT_FUNCTION'( CENTER_A_LINE ) , ROW_TYPE'( 23 ) ) ; -- filename is used so read it in to initialize the GRAPH_TREE TREE_IO.READ( TREE_IO.COMPLETE_FILE_NAME( SESSION_FILE_NAME , TREE_IO.TREE_EXTENSION )); -- now draw the tree UTIL_FOR_TREE.DRAW_GRAPH_TREE ; -- set up tree file name TREE_IO.DATA_FILENAME := SESSION_FILE_NAME ; else -- set up tree file name to default name DISPLAY_TIMED_MESSAGE ( "New file " & TREE_IO.DEFAULT_FILENAME ) ; TREE_IO.DATA_FILENAME := TREE_IO.DEFAULT_FILENAME ; end if ; exception -- CHECK_FOR_OLD_SESSION_NAME when NAME_ERROR => -- its a new session name so continue DISPLAY_TIMED_MESSAGE ( "New file " & SESSION_FILE_NAME ) ; TREE_IO.DATA_FILENAME := SESSION_FILE_NAME ; when others => -- unknown error so pass it on raise ; end CHECK_FOR_OLD_SESSION_NAME ; VIRTUAL_TERMINAL_INTERFACE.LOW_LEVEL_OPERATIONS ( VIRTUAL_TERMINAL_INTERFACE.ERASE_SCREEN ) ; MMI.PROCESS_COMMAND ; -- invoke GAD command processor exception -- catch any unhandled exceptions and notify the user. when OTHERS => -- abort and reset the Man-Machine Interface MMI.PANIC_EXIT ; -- notify the User of this abnormal termination TEXT_IO.PUT_LINE(" PANIC EXIT PROCESS COMPLETED "); -- propagate the exception so that the error can -- be examined in greater detail raise; end GAD ; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --tree_util.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- version 17 January 1986 by JR (improved integer range) -- version 1 November 1985 by JR with GKS_SPECIFICATION ; with GRAPHICS_DATA; use GRAPHICS_DATA ; with TEXT_IO; use TEXT_IO; with TREE_DATA; use TREE_DATA; with TREE_OPS; use TREE_OPS; with TREE_IO; use TREE_IO; with PDL_GEN; use PDL_GEN; procedure TREE_UTIL is ---------------------------------------------------------------------------- -- This utility program can be used to test and maintain trees -- built using the TREE facilities of the Graphic Ada Designer. ---------------------------------------------------------------------------- type NODE_TYPE is (TREE_NODES, LIST_NODES, GRAPH_NODES); FILENAME : FILENAME_TYPE := NULL_FILENAME; LENGTH : INTEGER; LIST_HEAD : LIST_NODE_ACCESS_TYPE; NODE_POINTER : TREE_NODE_ACCESS_TYPE := 1; NODE_POINTER2 : TREE_NODE_ACCESS_TYPE := 1; NODE_TYPE_IN_USE : NODE_TYPE := TREE_NODES; NODE_TYPE_TO_CREATE : ENTITY_TYPE := TYPE_PACKAGE; REQUESTED_LIST : LIST_TYPE := START; RESPONSE : STRING (1..80); TIME_TO_EXIT : BOOLEAN := FALSE; ------------------------------------------------------------------------- -- A function to print an image of a SEGMENT ------------------------------------------------------------------------- function SEGMENT_IMAGE (SEGMENT_ID: in GKS_SPECIFICATION.SEGMENT_NAME) return STRING is -- -- This function returns a string which is a printable -- image of the SEGMENT passed to it. -- INT_SEGMENT_ID : INTEGER := INTEGER( SEGMENT_ID ) ; begin return INTEGER'image (INT_SEGMENT_ID) ; end SEGMENT_IMAGE ; ------------------------------------------------------------------------- -- A function to print an image of a LIST ------------------------------------------------------------------------- function LIST_IMAGE (LIST_HEAD: in INTEGER) return STRING is -- -- This function returns a string which is a printable -- image of the List pointed to by LIST_HEAD -- function NEXT_IMAGE (PTR: in INTEGER) return STRING is -- a local function to process the elements after the -- list head (if any exist); LPTR : INTEGER; begin if PTR <= 0 then return INTEGER'image(PTR); else return INTEGER'image(PTR) & ", " & NEXT_IMAGE(LIST(PTR).NEXT); end if; end NEXT_IMAGE; begin if LIST_HEAD <= 0 then return INTEGER'image(LIST_HEAD); else return INTEGER'image(LIST_HEAD) & " [ " & NEXT_IMAGE(LIST(LIST_HEAD).NEXT) & " ]"; end if; end LIST_IMAGE; ------------------------------------------------------------------------- -- a procedure to view (display) a node of the selected type ------------------------------------------------------------------------- procedure VIEW_NODE (NODE_KIND: in NODE_TYPE; NUM: in INTEGER) is -- display the array element specified by num from the array -- type selected by NODE_KIND (TREE, LIST, or GRAPH). begin NEW_LINE; PUT_LINE (" NODE NUMBER: " & INTEGER'image(NUM)); case NODE_KIND is when TREE_NODES => PUT_LINE (" NODE_TYPE: "&ENTITY_TYPE'image(TREE(NUM).NODE_TYPE)); PUT_LINE (" NAME: "&TREE(NUM).NAME(1..25)); PUT_LINE (" PARENT: "&INTEGER'image(TREE(NUM).PARENT)); PUT_LINE (" GRAPH_NODE: "&INTEGER'image(TREE(NUM).GRAPH_DATA)); PUT_LINE (" MEMBERSHIP: " & LIST_IMAGE(TREE(NUM).MEMBERSHIP)); case TREE(NUM).NODE_TYPE is when ROOT .. TYPE_TASK => PUT_LINE (" CONTAINED: " & LIST_IMAGE(TREE(NUM).CONTAINED_ENTITY_LIST)); case TREE(NUM).NODE_TYPE is when TYPE_VIRTUAL_PACKAGE .. TYPE_FUNCTION => PUT_LINE (" GENERIC_STAT: "&TREE_DATA.GENERIC_STATUS_TYPE'image (TREE(NUM).GENERIC_STATUS)); PUT_LINE (" CU_INSTAN: "&TREE(NUM).CU_INSTANTIATED(1..25)); PUT_LINE (" PROLOG_PTR: " & INTEGER'image(TREE(NUM).PROLOGUE_PTR)); PUT_LINE (" BODY_PTR: " & INTEGER'image(TREE(NUM).BODY_PTR)); PUT_LINE (" DATA_LIST: " & LIST_IMAGE(TREE(NUM).DATA_CONNECT_LIST)); if TREE(NUM).NODE_TYPE = TYPE_VIRTUAL_PACKAGE or TREE(NUM).NODE_TYPE = TYPE_PACKAGE then PUT_LINE (" EXPORTED: " & LIST_IMAGE(TREE(NUM).EXPORTED_LIST)); PUT_LINE (" IMPORTED: " & LIST_IMAGE(TREE(NUM).IMPORTED_LIST)); elsif TREE(NUM).NODE_TYPE = TYPE_FUNCTION or TREE(NUM).NODE_TYPE = TYPE_PROCEDURE then PUT_LINE (" HAS_PARAMS: " & BOOLEAN'image(TREE(NUM).HAS_PARAMETERS)); end if; when TYPE_TASK => PUT_LINE (" PROLOG_PTR: " & INTEGER'image(TREE(NUM).PROLOGUE_PTR)); PUT_LINE (" BODY_PTR: " & INTEGER'image(TREE(NUM).BODY_PTR)); PUT_LINE (" DATA_LIST: " & LIST_IMAGE(TREE(NUM).DATA_CONNECT_LIST)); PUT_LINE (" TASK_STATUS: " & TASK_STATUS_TYPE'image(TREE(NUM).TASK_STATUS)); PUT_LINE (" ENTRY_LIST: " & LIST_IMAGE(TREE(NUM).ENTRY_LIST)); when others => null; end case; when TYPE_ENTRY_POINT => PUT_LINE (" IS_GUARDED: " & BOOLEAN'image(TREE(NUM).IS_GUARDED)); PUT_LINE (" WITH_PARAMS: " & BOOLEAN'image(TREE(NUM).WITH_PARAMETERS)); when TYPE_BODY => PUT_LINE (" CALLEE_LIST: " & LIST_IMAGE(TREE(NUM).CALLEE_LIST)); when EXPORTED_PROCEDURE .. CONNECTION_FOR_DATA => PUT_LINE (" CALL_VARIETY: "&CALL_CONNECTION_TYPE'image (TREE(NUM).CALL_VARIETY)); PUT_LINE (" CONNECTEE: "&INTEGER'image (TREE(NUM).CONNECTEE)); PUT (" LINE_POINTS: ") ; for I in 1..TREE_DATA.MAXIMUM_NO_LINE_SEGMENTS loop PUT (" " & INTEGER'image(TREE(NUM).LINE(I)) & ",") ; end loop ; NEW_LINE ; when others => null; end case; when LIST_NODES => PUT_LINE (" ITEM: "&INTEGER'image(LIST(NUM).ITEM)); PUT_LINE (" PRIOR: "&INTEGER'image(LIST(NUM).PRIOR)); PUT_LINE (" NEXT: "&INTEGER'image(LIST(NUM).NEXT)); PUT_LINE (" REF_COUNT: "&INTEGER'image(LIST(NUM).REF_COUNT)); when GRAPH_NODES => PUT_LINE (" OWNING_TREE: "&INTEGER'image(GRAPH(NUM).OWNING_TREE_NODE)); PUT_LINE (" DATA.SEGMENT: "&SEGMENT_IMAGE(GRAPH(NUM).DATA.SEGMENT_ID)); PUT_LINE (" DATA.LAB_SEG: "&SEGMENT_IMAGE(GRAPH(NUM).DATA.LABEL_SEG_ID)); PUT_LINE (" DATA.LAB_SG2: "&SEGMENT_IMAGE(GRAPH(NUM).DATA.LABEL2_SEG_ID)); PUT_LINE (" DATA.LOC.X: "&INTEGER'image(GRAPH(NUM).DATA.LOCATION.X)); PUT_LINE (" DATA.LOC.Y: "&INTEGER'image(GRAPH(NUM).DATA.LOCATION.Y)); PUT_LINE (" DATA.SIZE.X: "&INTEGER'image(GRAPH(NUM).DATA.SIZE.X)); PUT_LINE (" DATA.SIZE.Y: "&INTEGER'image(GRAPH(NUM).DATA.SIZE.Y)); end case; end VIEW_NODE; ------------------------------------------------------------------------- function INTEGER_VALUE (TEXT: in STRING) return INTEGER is -- substitutes for the missing INTEGER'VALUE function NEGATIVE : BOOLEAN := FALSE; NUM : INTEGER := 0; begin for I in TEXT'range loop case TEXT(I) is when '-' => if I /= TEXT'first then raise NUMERIC_ERROR; else NEGATIVE := TRUE; end if; when '0' => NUM := NUM*10; when '1' => NUM := NUM*10 + 1; when '2' => NUM := NUM*10 + 2; when '3' => NUM := NUM*10 + 3; when '4' => NUM := NUM*10 + 4; when '5' => NUM := NUM*10 + 5; when '6' => NUM := NUM*10 + 6; when '7' => NUM := NUM*10 + 7; when '8' => NUM := NUM*10 + 8; when '9' => NUM := NUM*10 + 9; when others => raise NUMERIC_ERROR; end case; end loop; if NEGATIVE then return -NUM; else return NUM; end if; end INTEGER_VALUE; ------------------------------------------------------------------------- -- procedures to edit Nodes values ------------------------------------------------------------------------- procedure EDIT (PROMPT: in STRING; VALUE: in out INTEGER) is -- allows user to edit the value or keep old value BAD_VALUE_ENTERED : exception; DONE : BOOLEAN := FALSE; LENGTH : INTEGER; LINE : STRING (1..80); NEW_VALUE : INTEGER := -999; begin while not DONE loop begin PUT (PROMPT & " (" & INTEGER'image(VALUE) & ") >"); GET_LINE (LINE, LENGTH); -- skip unless a new value was entered if LENGTH > 0 then NEW_VALUE := INTEGER_VALUE (LINE(1..LENGTH)); if NEW_VALUE < -1 or NEW_VALUE > 32768 then raise BAD_VALUE_ENTERED; end if; VALUE := NEW_VALUE; end if; DONE := TRUE; -- exit the loop exception when BAD_VALUE_ENTERED => PUT_LINE (" BAD VALUE ENTERED (out of range) - Try Again "); when others => PUT_LINE (" VALUE NOT ENTERED CORRECTLY - Try Again "); end; end loop; end EDIT; procedure EDIT (PROMPT: in STRING; VALUE: in out GKS_SPECIFICATION.SEGMENT_NAME) is -- allows user to edit the value or keep old value INT_VALUE : INTEGER := INTEGER( VALUE ) ; begin EDIT ( PROMPT, INT_VALUE ) ; VALUE := GKS_SPECIFICATION.SEGMENT_NAME( INT_VALUE ) ; end EDIT ; procedure EDIT (PROMPT: in STRING; VALUE: in out BOOLEAN) is -- allows user to edit the value or keep old value DONE : BOOLEAN := FALSE; LENGTH : INTEGER; LINE : STRING (1..80); begin while not DONE loop begin PUT (PROMPT & " (" & BOOLEAN'image(VALUE) & ") >"); GET_LINE (LINE, LENGTH); -- skip unless a new value was entered if LENGTH > 0 then VALUE := BOOLEAN'value (LINE(1..LENGTH)); end if; DONE := TRUE; -- exit the loop exception when others => PUT_LINE (" VALUE NOT ENTERED CORRECTLY - Try Again "); end; end loop; end EDIT; procedure EDIT (PROMPT: in STRING; VALUE: in out STRING) is -- allows user to edit the value or keep old value BAD_VALUE_ENTERED : exception; DONE : BOOLEAN := FALSE; LENGTH : INTEGER; LINE : STRING (1..80) := " "& " "; -- fill line to insure a replacement string is trailed by blanks begin while not DONE loop begin if VALUE'last < 25 then PUT (PROMPT & " (" & VALUE & ") >"); else PUT (PROMPT & " (" & VALUE(1..25) & ") >"); end if; GET_LINE (LINE, LENGTH); -- skip unless a new value was entered if LENGTH > 0 then VALUE := LINE (1..VALUE'last); end if; DONE := TRUE; -- exit the loop exception when others => PUT_LINE (" VALUE NOT ENTERED CORRECTLY - Try Again "); end; end loop; end EDIT; procedure EDIT (PROMPT: in STRING; VALUE: in out ENTITY_TYPE) is -- allows user to edit the value or keep old value BAD_VALUE_ENTERED : exception; DONE : BOOLEAN := FALSE; LENGTH : INTEGER; LINE : STRING (1..80) ; begin while not DONE loop begin PUT (PROMPT & " (" & ENTITY_TYPE'image(VALUE) & ") >"); GET_LINE (LINE, LENGTH); -- skip unless a new value was entered if LENGTH > 0 then VALUE := ENTITY_TYPE'value( LINE(1..LENGTH) ); end if; DONE := TRUE; -- exit the loop exception when others => PUT_LINE (" VALUE NOT ENTERED CORRECTLY - Try Again "); end; end loop; end EDIT; procedure EDIT (PROMPT: in STRING; VALUE: in out LIST_TYPE) is -- allows user to edit the value or keep old value BAD_VALUE_ENTERED : exception; DONE : BOOLEAN := FALSE; LENGTH : INTEGER; LINE : STRING (1..80) ; begin while not DONE loop begin PUT (PROMPT & " (" & LIST_TYPE'image(VALUE) & ") >"); GET_LINE (LINE, LENGTH); -- skip unless a new value was entered if LENGTH > 0 then VALUE := LIST_TYPE'value( LINE(1..LENGTH) ); end if; DONE := TRUE; -- exit the loop exception when others => PUT_LINE (" VALUE NOT ENTERED CORRECTLY - Try Again "); end; end loop; end EDIT; procedure EDIT (PROMPT: in STRING; VALUE: in out CALL_CONNECTION_TYPE) is -- allows user to edit the value or keep old value BAD_VALUE_ENTERED : exception; DONE : BOOLEAN := FALSE; LENGTH : INTEGER; LINE : STRING (1..80) ; begin while not DONE loop begin PUT (PROMPT & " (" & CALL_CONNECTION_TYPE'image(VALUE) & ") >"); GET_LINE (LINE, LENGTH); -- skip unless a new value was entered if LENGTH > 0 then VALUE := CALL_CONNECTION_TYPE'value( LINE(1..LENGTH) ); end if; DONE := TRUE; -- exit the loop exception when others => PUT_LINE (" VALUE NOT ENTERED CORRECTLY - Try Again "); end; end loop; end EDIT; procedure EDIT (PROMPT: in STRING; VALUE: in out TREE_DATA.GENERIC_STATUS_TYPE) is -- allows user to edit the value or keep old value BAD_VALUE_ENTERED : exception; DONE : BOOLEAN := FALSE; LENGTH : INTEGER; LINE : STRING (1..80); begin while not DONE loop begin PUT (PROMPT & " (" & TREE_DATA.GENERIC_STATUS_TYPE'image(VALUE) & ") >"); GET_LINE (LINE, LENGTH); -- skip unless a new value was entered if LENGTH > 0 then VALUE := TREE_DATA.GENERIC_STATUS_TYPE'value( LINE(1..LENGTH) ); end if; DONE := TRUE; -- exit the loop exception when others => PUT_LINE (" VALUE NOT ENTERED CORRECTLY - Try Again "); end; end loop; end EDIT; procedure EDIT (PROMPT: in STRING; VALUE: in out TASK_STATUS_TYPE) is -- allows user to edit the value or keep old value BAD_VALUE_ENTERED : exception; DONE : BOOLEAN := FALSE; LENGTH : INTEGER; LINE : STRING (1..80); begin while not DONE loop begin PUT (PROMPT & " (" & TASK_STATUS_TYPE'image(VALUE) & ") >"); GET_LINE (LINE, LENGTH); -- skip unless a new value was entered if LENGTH > 0 then VALUE := TASK_STATUS_TYPE'value( LINE(1..LENGTH) ); end if; DONE := TRUE; -- exit the loop exception when others => PUT_LINE (" VALUE NOT ENTERED CORRECTLY - Try Again "); end; end loop; end EDIT; ------------------------------------------------------------------------- -- The procedure to edit the contents of a node ------------------------------------------------------------------------- procedure EDIT_NODE (NODE_KIND: in NODE_TYPE; NUM: in INTEGER) is -- allows the user to edit the selected node, keeping old -- values if that is desired. LGRAPH : GRAPH_NODE_TYPE; LLIST : LIST_NODE_TYPE; LTREE : TREE_NODE_TYPE; begin case NODE_KIND is when TREE_NODES => LTREE := TREE(NUM); NEW_LINE; PUT_LINE (" NODE_TYPE: " & ENTITY_TYPE'image(LTREE.NODE_TYPE)); EDIT (" NAME: ", LTREE.NAME); EDIT (" PARENT: ", LTREE.PARENT); EDIT (" GRAPH_NODE: ", LTREE.GRAPH_DATA); EDIT (" MEMBERSHIP: ", LTREE.MEMBERSHIP); case TREE(NUM).NODE_TYPE is when ROOT .. TYPE_TASK => EDIT (" CONTAINED: ", LTREE.CONTAINED_ENTITY_LIST); case LTREE.NODE_TYPE is when TYPE_VIRTUAL_PACKAGE .. TYPE_FUNCTION => EDIT (" GENERIC_STAT: ", LTREE.GENERIC_STATUS); EDIT (" CU_INSTAN: ", LTREE.CU_INSTANTIATED); EDIT (" PROLOG_PTR: ", LTREE.PROLOGUE_PTR); EDIT (" BODY_PTR: ", LTREE.BODY_PTR); EDIT (" DATA_LIST: ", LTREE.DATA_CONNECT_LIST); if LTREE.NODE_TYPE = TYPE_VIRTUAL_PACKAGE or LTREE.NODE_TYPE = TYPE_PACKAGE then EDIT (" EXPORTED: ", LTREE.EXPORTED_LIST); EDIT (" IMPORTED: ", LTREE.IMPORTED_LIST); elsif TREE(NUM).NODE_TYPE = TYPE_FUNCTION or TREE(NUM).NODE_TYPE = TYPE_PROCEDURE then EDIT (" HAS_PARAMS: ", LTREE.HAS_PARAMETERS); end if; when TYPE_TASK => EDIT (" PROLOG_PTR: ", LTREE.PROLOGUE_PTR); EDIT (" BODY_PTR: ", LTREE.BODY_PTR); EDIT (" DATA_LIST: ", LTREE.DATA_CONNECT_LIST); EDIT (" TASK_STATUS: ", LTREE.TASK_STATUS); EDIT (" ENTRY_LIST: ", LTREE.ENTRY_LIST); when others => null; end case; when TYPE_ENTRY_POINT => EDIT (" IS_GUARDED: ", LTREE.IS_GUARDED); EDIT (" WITH_PARAMS: ", LTREE.WITH_PARAMETERS); when TYPE_BODY => EDIT (" CALLEE_LIST: ", LTREE.CALLEE_LIST); when EXPORTED_PROCEDURE .. CONNECTION_FOR_DATA => EDIT (" CALL_VARIETY: ", LTREE.CALL_VARIETY); EDIT (" CONNECTEE: ", LTREE.CONNECTEE); when others => null; end case; -- place the new values in the array TREE(NUM) := LTREE; when LIST_NODES => LLIST := LIST(NUM); NEW_LINE; EDIT (" ITEM: ", LLIST.ITEM); EDIT (" PRIOR: ", LLIST.PRIOR); EDIT (" NEXT: ", LLIST.NEXT); -- place the new values in the array LIST(NUM) := LLIST; when GRAPH_NODES => LGRAPH := GRAPH(NUM); NEW_LINE; EDIT (" OWNING_TREE: ", LGRAPH.OWNING_TREE_NODE); EDIT (" DATA.SEGMENT: ", LGRAPH.DATA.SEGMENT_ID); EDIT (" DATA.LAB_SEG: ", LGRAPH.DATA.LABEL_SEG_ID); EDIT (" DATA.LAB_SG2: ", LGRAPH.DATA.LABEL2_SEG_ID); EDIT (" DATA.LOC.X: ", LGRAPH.DATA.LOCATION.X); EDIT (" DATA.LOC.Y: ", LGRAPH.DATA.LOCATION.Y); EDIT (" DATA.SIZE.X: ", LGRAPH.DATA.SIZE.X); EDIT (" DATA.SIZE.Y: ", LGRAPH.DATA.SIZE.Y); GRAPH(NUM) := LGRAPH; end case; exception when others => PUT_LINE (" error in data entry - input ignored "); end EDIT_NODE; begin NEW_LINE; PUT_LINE (" TREE EDITOR ready "); while not TIME_TO_EXIT loop begin NEW_LINE; RESPONSE (1..10) := " "; NEW_LINE; PUT (">"); GET_LINE (RESPONSE, LENGTH); if LENGTH = 0 then -- view the next node NODE_POINTER := NODE_POINTER + 1; VIEW_NODE (NODE_TYPE_IN_USE, NODE_POINTER); else -- process the requested command case RESPONSE(1) is when 'C'|'c' => -- create the new nodes case NODE_TYPE_IN_USE is when TREE_NODES => EDIT (" Node Type to be Created ", NODE_TYPE_TO_CREATE); NODE_POINTER := GET_NEW_TREE_NODE (NODE_TYPE_TO_CREATE); when LIST_NODES => -- initially point to the root tree node (1) NODE_POINTER := GET_NEW_LIST_NODE (1); when GRAPH_NODES => -- initially attach the node to the root tree node (1) NODE_POINTER := GET_NEW_GRAPH_NODE (1); end case; PUT_LINE (" Node Created is > " & INTEGER'image(NODE_POINTER) ); EDIT_NODE (NODE_TYPE_IN_USE, NODE_POINTER); when 'D'|'d' => NEW_LINE; EDIT (" ENTER NODE TO DELETE ", NODE_POINTER); case NODE_TYPE_IN_USE is when TREE_NODES => RELEASE_TREE_NODE (NODE_POINTER); when LIST_NODES => NODE_POINTER2 := NULL_POINTER; RELEASE_LIST_NODE (NODE_POINTER); when GRAPH_NODES => RELEASE_GRAPH_NODE (NODE_POINTER); end case; when 'E'|'e' => TIME_TO_EXIT := TRUE; -- exit the command processing loop when 'G'|'g' => NODE_TYPE_IN_USE := GRAPH_NODES; PUT_LINE (" GRAPH NODES now in use "); when 'H'|'h'|'?' => NEW_LINE; PUT_LINE (" CREATE a new node "); PUT_LINE (" DELETE a node "); PUT_LINE (" EXIT "); PUT_LINE (" GRAPH nodes to be displayed and modified "); PUT_LINE (" HELP "); PUT_LINE (" INSERT a list node into a list "); PUT_LINE (" LIST nodes to be displayed and modified "); PUT_LINE (" MODIFY a node "); PUT_LINE (" PDL generation "); PUT_LINE (" READ a tree file "); PUT_LINE (" TREE nodes to be displayed and modified "); PUT_LINE (" VIEW a node "); PUT_LINE (" WRITE a tree file "); PUT_LINE (" <num> to view a node of that number "); when 'I'|'i' => EDIT (" ENTER TREE NODE WITH LIST ", NODE_POINTER); EDIT (" ENTER LIST TO BE PLACED ON >", REQUESTED_LIST); EDIT (" ENTER LIST NODE TO INSERT ", NODE_POINTER2); ADD_NODE_TO_LIST (NODE_POINTER, REQUESTED_LIST, NODE_POINTER2); when 'L'|'l' => NODE_TYPE_IN_USE := LIST_NODES; PUT_LINE (" LIST NODES now in use "); when 'M'|'m' => NEW_LINE; EDIT (" ENTER NODE TO MODIFY ", NODE_POINTER); EDIT_NODE (NODE_TYPE_IN_USE, NODE_POINTER); when 'P'|'p' => -- perform PDL Generation on current tree declare FILEHANDLE : FILE_TYPE; begin PUT (" DO YOU WANT TRACING (NO) ? "); GET_LINE (RESPONSE,LENGTH); if LENGTH > 0 and then ( RESPONSE(1)='Y' or RESPONSE(1)='y' ) then TRACE_GENERATION := TRUE; else TRACE_GENERATION := FALSE; end if; if FILENAME = NULL_FILENAME then GENERATE_PDL (TREE_IO.DEFAULT_FILENAME) ; else GENERATE_PDL (FILENAME) ; end if ; end; when 'R'|'r' => FILENAME := NULL_FILENAME; NEW_LINE; PUT (" ENTER NAME OF FILE TO READ FROM > "); GET_LINE (FILENAME,LENGTH); if LENGTH > 0 then READ ( COMPLETE_FILE_NAME ( FILENAME, TREE_EXTENSION ) ); end if; when 'T'|'t' => NODE_TYPE_IN_USE := TREE_NODES; PUT_LINE (" TREE NODES now in use "); when 'V'|'v' => NEW_LINE; EDIT (" ENTER NODE TO VIEW ", NODE_POINTER); VIEW_NODE (NODE_TYPE_IN_USE, NODE_POINTER); when 'W'|'w' => FILENAME := NULL_FILENAME; NEW_LINE; PUT (" ENTER NAME OF FILE TO WRITE TO > "); GET_LINE (FILENAME,LENGTH); if LENGTH > 0 then WRITE ( COMPLETE_FILE_NAME ( FILENAME, TREE_EXTENSION ) ); end if; when '0'..'9' => NODE_POINTER := INTEGER_VALUE (RESPONSE(1..LENGTH)); VIEW_NODE (NODE_TYPE_IN_USE, NODE_POINTER); when others => NEW_LINE; PUT_LINE (" Invalid Command - Please Try Again "); NEW_LINE; end case; end if; exception when others => PUT_LINE (" Error Trapped by Exception Handler - Continuing "); end; end loop; end TREE_UTIL; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --support_package_spec.ada --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: package SUPPORT_PACKAGE is type TBD_TYPE is (TBD) ; -- used as function return value TBD_OBJECT : TBD_TYPE ; -- the function return value TBD_PARAMETERS : TBD_TYPE ; -- the subprogram calling parameters TBD_TIME : DURATION ; -- used in delay statements TBD_CONDITION : BOOLEAN ; -- used in conditional statements end SUPPORT_PACKAGE ;