Procedure Pointer Playthings
Gregory Alan Bolcer
self-contained) demo of how addresses can be used as procedure pointers
in Ada without mysterious (or not so mysterious) data corruptions,
hardware misalignments, etc. This example is compiled using the Verdix
6.0(g) sun4 compiler running on a Sparcstation. It includes a Makefile
that should be able to get the demo running given that an Ada library
exists. I would appreciate any comments about the usage or the code.
Greg
--------cut here---------------------------------------------------------
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of shell archive."
# Contents: Q.a Q.h QDR.a QDR.body.a QDR.c QDR.h Q_dep.a ada.lib
# ada_test.a addcall.c gnrx.lib procs.a procs.body.a test.old.a
# wrap.a
# Wrapped by gbo...@siam.ics.uci.edu on Wed May 16 15:37:36 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'Q.a' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Q.a'\"
else
echo shar: Extracting \"'Q.a'\" \(1659 characters\)
sed "s/^X//" >'Q.a' <<'END_OF_FILE'
X--
X-- Copyright (c) 1989 by the Regents of the University of California,
X-- and TRW
X--
X-- TITLE: Q: Towards a Multi-lingual Interprocess Communications Model
X--
X-- DESCRIPTION:
X--
X-- This software represents the first step in an attempt to provide
X-- a generalized multi-lingual interprocess communications model.
X-- This software provides a consistent set of interfaces for the C
X-- and Ada programming languages to permit interprocess communications
X-- between processes of either language.
X--
X-- AUTHORS: Mark Maybee
X-- University of California, Irvine
X--
X-- Stephen D. Sykes
X-- TRW
X--
X-- HISTORY:
X--
X-- This software is built on top of the standard XDR/RPC communications
X-- model proposed by Sun Microsystems. It also draws heavely from an
X-- earlier effort in this area by Mark Maybee and Dennis Heimbigner.
X--
X
X--
X-- Q global definitions
X--
X-- This package defines those global symbols used throughout
X-- the Q communications model implementation.
X--
X-- AUTHOR: Maybee & Sykes CREATION DATE: JAN-1989
X--
XWITH System;
X
XPACKAGE Q IS
X
X -- types
X
X SUBTYPE Address IS System.Address;
X MAX_INT : CONSTANT := System.MAX_INT;
X NO_ADDR : CONSTANT Address := System.NO_ADDR;
X -- the definition of NULL_ADDR is system dependant and
X -- should be defined as an impossible address.
X
X SUBTYPE Integers IS Integer;
X -- a 32 bit integer number with range -2**31..(2**31) -1.
X -- TYPE Integers IS RANGE -(2**31)..(2..31)-1;
X -- FOR Integers'SIZE USE 32;
X
X SUBTYPE Floating IS Float;
X -- a floating point number whose exact nature is defined
X -- in the IEEE standard on 64bit floating point numbers.
X
X TYPE String_ref IS ACCESS String;
X
XEND Q;
END_OF_FILE
if test 1659 -ne `wc -c <'Q.a'`; then
echo shar: \"'Q.a'\" unpacked with wrong size!
fi
# end of 'Q.a'
fi
if test -f 'Q.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Q.h'\"
else
echo shar: Extracting \"'Q.h'\" \(2005 characters\)
sed "s/^X//" >'Q.h' <<'END_OF_FILE'
X/*
X** Copyright (c) 1989 by the Regents of the University of California
X** and TRW
X**
X** TITLE: Q: Towards a Multi-lingual Interprocess Communications Model
X**
X** DESCRIPTION:
X**
X** This software represents the first step in an attempt to provide
X** a generalized multi-lingual interprocess communications model.
X** This software provides a consistent set of interfaces for the C
X** and Ada programming languages to permit interprocess communications
X** between processes of either language.
X**
X** AUTHORS: Mark Maybee
X** University of California, Irvine
X**
X** Stephen D. Sykes
X** TRW
X**
X** HISTORY:
X**
X** This software is built on top of the standard XDR/RPC communications
X** model proposed by Sun Microsystems. It also draws heavely from an
X** earlier effort in this area by Mark Maybee and Dennis Heimbigner.
X*/
X
X/*
X * Q global definitions
X *
X * This package defines those global symbols and types used
X * throughout the Q communications model implementation.
X *
X * AUTHOR: Maybee & Sykes CREATION DATE: JAN-1989
X */
X#ifndef _Q_SPECIFICATION_
X#define _Q_SPECIFICATION_
X
X /* types */
X
X/*
X * Type Q_Integer is at a minimum a 32 bit integer, which supports
X * values in the range - 2**31 ..(2**31) -1
X */
X typedef int Q_Integer;
X
X/*
X * Type Q_Floating is a floating point number whose exact nature is
X * defined in the IEEE standard on 64 bit floating point numbers
X */
X typedef double Q_Floating;
X
X/*
X * Type Q_Bool is an enumeration type with two elements.
X */
X typedef enum { Q_FALSE = 0,
X Q_TRUE = 1 } Q_Bool;
X
X/*
X * Type Q_Strbuf is a string type which includes a length attribute
X */
X typedef struct { u_int length;
X caddr_t data; } Q_Strbuf;
X
X#endif _Q_SPECIFICATION_
END_OF_FILE
if test 2005 -ne `wc -c <'Q.h'`; then
echo shar: \"'Q.h'\" unpacked with wrong size!
fi
# end of 'Q.h'
fi
if test -f 'QDR.a' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'QDR.a'\"
else
echo shar: Extracting \"'QDR.a'\" \(3905 characters\)
sed "s/^X//" >'QDR.a' <<'END_OF_FILE'
X--
X-- Copyright (c) 1989 by the Regents of the University of California,
X-- and TRW
X--
X-- TITLE: Q: Towards a Multi-lingual Interprocess Communications Model
X--
X-- DESCRIPTION:
X--
X-- This software represents the first step in an attempt to provide
X-- a generalized multi-lingual interprocess communications model.
X-- This software provides a consistent set of interfaces for the C
X-- and Ada programming languages to permit interprocess communications
X-- between processes of either language.
X--
X-- AUTHORS: Mark Maybee
X-- University of California, Irvine
X--
X-- Stephen D. Sykes
X-- TRW
X--
X-- HISTORY:
X--
X-- This software is built on top of the standard XDR/RPC communications
X-- model proposed by Sun Microsystems. It also draws heavely from an
X-- earlier effort in this area by Mark Maybee and Dennis Heimbigner.
X--
X
X--
X-- Q Data Representation Support Library
X--
X-- This package defines the routine interfaces with which
X-- to achieve the Q Data Representation (QDR). This
X-- representation is based heavily upon the XDR standard.
X--
X-- AUTHOR: Maybee & Sykes CREATION DATE: JAN-1989
X--
XWITH Q;
XWITH Q_dep;
X
XPACKAGE QDR IS
X
X --
X -- QDR buffer types and routines
X --
X
X TYPE Handle IS PRIVATE;
X
X NULL_HANDLE : CONSTANT Handle;
X
X FUNCTION create
X RETURN Handle;
X
X PROCEDURE destroy (
X qdrs : IN Handle
X );
X
X -- set for writing
X PROCEDURE set_write (
X qdrs : IN Handle
X );
X
X -- set for reading
X PROCEDURE set_read (
X qdrs : IN Handle
X );
X
X -- get buffer size
X FUNCTION size (
X qdrs : IN Handle
X ) RETURN Integer;
X
X -- linearize QDR buffer
X FUNCTION linearize (
X qdrs : IN Handle
X ) RETURN Q.String_ref;
X
X -- delinearize QDR buffer
X FUNCTION delinearize (
X qdrs : IN Handle := NULL_HANDLE;
X buffer : IN String
X ) RETURN Handle;
X
X
X --
X -- Support for basic scalar types:
X --
X
X -- integer:
X GENERIC
X TYPE Int_type IS RANGE <>;
X PROCEDURE generic_integer (
X qdrs : IN Handle;
X i : IN OUT Int_type
X );
X
X -- floating:
X GENERIC
X TYPE Float_type IS DIGITS <>;
X PROCEDURE generic_floating (
X qdrs : IN Handle;
X f : IN OUT Float_type
X );
X
X -- fixed:
X GENERIC
X TYPE Fixed_type IS DELTA <>;
X PROCEDURE generic_fixed (
X qdrs : IN Handle;
X f : IN OUT Fixed_type
X );
X
X -- enumeration:
X GENERIC
X TYPE Enum_type IS (<>);
X PROCEDURE generic_enumeration (
X qdrs : IN Handle;
X e : IN OUT Enum_type
X );
X
X -- boolean (special case of enumeration type):
X PROCEDURE bool (
X qdrs : IN Handle;
X b : IN OUT Boolean
X );
X
X -- string
X PROCEDURE strings (
X qdrs : IN Handle;
X sp : IN OUT Q.String_ref
X );
X
X PROCEDURE string_slice (
X qdrs : IN Handle;
X str : IN String
X );
X
X -- "raw" data
X GENERIC
X TYPE Opaque_type IS PRIVATE;
X PROCEDURE generic_opaque (
X qdrs : IN Handle;
X data : IN OUT Opaque_type
X );
X
X -- pointer (can be null):
X GENERIC
X TYPE Struct_type IS PRIVATE;
X TYPE Pointer IS ACCESS Struct_type;
X WITH PROCEDURE struct (
X qdrs : IN Handle;
X sp : IN OUT Struct_type
X );
X PROCEDURE generic_pointer (
X qdrs : IN Handle;
X pp : IN OUT Pointer
X );
X
X -- arrays
X GENERIC
X TYPE Struct_type IS PRIVATE;
X TYPE Index IS (<>);
X TYPE Struct_array IS ARRAY (Index RANGE <>) OF Struct_type;
X WITH PROCEDURE struct (
X qdrs : IN Handle;
X sp : IN OUT Struct_type
X );
X PROCEDURE generic_array (
X qdrs : IN Handle;
X a : IN OUT Struct_array
X );
X
X
X --
X -- Exceptions
X --
X
X QDR_INTERNAL_ERROR : EXCEPTION;
X
XPRIVATE
X
X TYPE Handle IS NEW Q_dep.Address;
X
X NULL_HANDLE : CONSTANT Handle := Handle(Q_dep.NO_ADDR);
X
X PRAGMA Interface (C, create);
X PRAGMA Interface_Name (create, "_qdr_create");
X
X PRAGMA Interface (C, destroy);
X PRAGMA Interface_Name (destroy, "_qdr_destroy");
X
X PRAGMA Interface (C, set_write);
X PRAGMA Interface_Name (set_write, "_qdr_set_write");
X
X PRAGMA Interface (C, set_read);
X PRAGMA Interface_Name (set_read, "_qdr_set_read");
X
X PRAGMA Interface (C, size);
X PRAGMA Interface_Name (size, "_qdr_size");
X
XEND QDR;
END_OF_FILE
if test 3905 -ne `wc -c <'QDR.a'`; then
echo shar: \"'QDR.a'\" unpacked with wrong size!
fi
# end of 'QDR.a'
fi
if test -f 'QDR.body.a' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'QDR.body.a'\"
else
echo shar: Extracting \"'QDR.body.a'\" \(8960 characters\)
sed "s/^X//" >'QDR.body.a' <<'END_OF_FILE'
X--
X-- Copyright (c) 1989 by the Regents of the University of California,
X-- and TRW
X--
X-- TITLE: Q: Towards a Multi-lingual Interprocess Communications Model
X--
X-- DESCRIPTION:
X--
X-- This software represents the first step in an attempt to provide
X-- a generalized multi-lingual interprocess communications model.
X-- This software provides a consistent set of interfaces for the C
X-- and Ada programming languages to permit interprocess communications
X-- between processes of either language.
X--
X-- AUTHORS: Mark Maybee
X-- University of California, Irvine
X--
X-- Stephen D. Sykes
X-- TRW
X--
X-- HISTORY:
X--
X-- This software is built on top of the standard XDR/RPC communications
X-- model proposed by Sun Microsystems. It also draws heavely from an
X-- earlier effort in this area by Mark Maybee and Dennis Heimbigner.
X--
X
X--
X-- Q Data Representation Support Library
X--
X-- This package contains the implementation of the routines
X-- to achieve the Q Data Representation (QDR). It utilizes the
X-- C implementation routines for this standard which in turn
X-- are based heavily upon the XDR standard.
X--
X-- AUTHOR: Mark Maybee CREATION DATE: MAY-1989
X--
XWITH Q; USE Q;
XWITH Q_dep;
X
XPACKAGE BODY QDR IS
X
X
X TYPE C_Buffer IS RECORD
X length : Integer;
X data : Q_dep.Address;
X END RECORD;
X FOR C_Buffer USE RECORD at mod 2;
X length at 0 range 0..31;
X data at 4 range 0..31;
X END RECORD;
X
X QDR_WRITE : CONSTANT Integer := 0;
X QDR_READ : CONSTANT Integer := 1;
X QDR_FREE : CONSTANT Integer := 2;
X
X --
X -- C support library interfaces
X --
X FUNCTION C_qdr_mode (
X qdrs : IN Q_dep.Address
X ) RETURN Integer;
X PRAGMA Interface (C, C_qdr_mode);
X PRAGMA Interface_Name (C_qdr_mode, "_qdr_mode");
X
X PROCEDURE C_qdr_linearize (
X qdrs : IN Q_dep.Address;
X sp : IN Q_dep.Address
X );
X PRAGMA Interface (C, C_qdr_linearize);
X PRAGMA Interface_Name (C_qdr_linearize, "_qdr_linearize");
X
X FUNCTION C_qdr_delinearize (
X qdrs : IN Q_dep.Address;
X sp : IN Q_dep.Address;
X l : IN Integer
X ) RETURN Q_dep.Address;
X PRAGMA Interface (C, C_qdr_delinearize);
X PRAGMA Interface_Name (C_qdr_delinearize, "_qdr_delinearize");
X
X FUNCTION C_qdr_integer (
X qdrs : IN Q_dep.Address;
X ip : IN Q_dep.Address
X ) RETURN Integer;
X PRAGMA Interface (C, C_qdr_integer);
X PRAGMA Interface_Name (C_qdr_integer, "_qdr_integer");
X
X FUNCTION C_qdr_floating (
X qdrs : IN Q_dep.Address;
X fp : IN Q_dep.Address
X ) RETURN Integer;
X PRAGMA Interface (C, C_qdr_floating);
X PRAGMA Interface_Name (C_qdr_floating, "_qdr_floating");
X
X FUNCTION C_qdr_bool(
X qdrs : IN Q_dep.Address;
X bp : IN Q_dep.Address
X ) RETURN Integer;
X PRAGMA Interface (C, C_qdr_bool);
X PRAGMA Interface_Name (C_qdr_bool, "_qdr_bool");
X
X FUNCTION C_qdr_bytes (
X qdrs : IN Q_dep.Address;
X bp : IN Q_dep.Address;
X lp : IN Q_dep.Address;
X maxsize : IN Integer
X ) RETURN Integer;
X PRAGMA Interface (C, C_qdr_bytes);
X PRAGMA Interface_Name (C_qdr_bytes, "_qdr_bytes");
X
X FUNCTION C_qdr_opaque (
X qdrs : IN Q_dep.Address;
X bp : IN Q_dep.Address;
X l : IN Integer
X ) RETURN Integer;
X PRAGMA Interface (C, C_qdr_opaque);
X PRAGMA Interface_Name (C_qdr_opaque, "_qdr_opaque");
X
X FUNCTION C_bcopy (
X src : IN Q_dep.Address;
X dest : IN Q_dep.Address;
X length : IN Integer
X ) RETURN Integer;
X PRAGMA Interface (C, C_bcopy);
X PRAGMA Interface_Name (C_bcopy, "_bcopy");
X
X PROCEDURE C_free (
X pntr : IN Q_dep.Address
X );
X PRAGMA Interface (C, C_free);
X PRAGMA Interface_Name (C_free, "_free");
X
X --
X -- QDR buffer types and routines
X --
X
X -- linearize QDR buffer
X FUNCTION linearize (
X qdrs : IN Handle
X ) RETURN Q.String_ref IS
X temp : C_Buffer;
X buffer : Q.String_ref;
X stat : Integer;
X BEGIN
X temp.data := Q_dep.NO_ADDR;
X C_qdr_linearize (Q_dep.Address(qdrs), temp'ADDRESS);
X buffer := NEW String (1..temp.length);
X stat := C_bcopy (temp.data, buffer.ALL'ADDRESS, temp.length);
X C_free (temp.data);
X RETURN buffer;
X END linearize;
X
X -- delinearize QDR buffer
X FUNCTION delinearize (
X qdrs : IN Handle := NULL_HANDLE;
X buffer : IN String
X ) RETURN Handle IS
X temp : Handle;
X stat : Integer;
X BEGIN
X IF qdrs = NULL_HANDLE THEN
X temp := create;
X ELSE
X IF C_qdr_mode(Q_dep.Address(qdrs)) /= QDR_WRITE THEN
X set_write (qdrs);
X END IF;
X temp := qdrs;
X END IF;
X stat := C_qdr_opaque (Q_dep.Address(temp),
X buffer'ADDRESS, buffer'LENGTH);
X IF stat = 0 THEN
X RAISE QDR_INTERNAL_ERROR;
X END IF;
X RETURN temp;
X END delinearize;
X
X --
X -- Support for basic scalar types:
X --
X
X -- integer:
X -- This function converts everything to Q.Integer
X -- (as per the QDR standard) for storage.
X PROCEDURE generic_integer (
X qdrs : IN Handle;
X i : IN OUT Int_type
X ) IS
X stat : Integer;
X temp : Q.Integers;
X BEGIN
X IF Int_type'SIZE > Q.Integers'SIZE THEN
X RAISE CONSTRAINT_ERROR;
X ELSE
X temp := Q.Integers(i);
X stat := C_qdr_integer (Q_dep.Address(qdrs),
X temp'ADDRESS);
X END IF;
X IF stat = 0 THEN
X RAISE CONSTRAINT_ERROR;
X END IF;
X i := Int_type(temp);
X END generic_integer;
X
X -- floating:
X -- This function converts everything to Q.Floating
X -- (as per the QDR standard) for storage.
X PROCEDURE generic_floating (
X qdrs : IN Handle;
X f : IN OUT Float_type
X ) IS
X temp : Q.Floating;
X stat : Integer;
X BEGIN
X temp := Q.Floating(f);
X stat := C_qdr_floating (Q_dep.Address(qdrs), temp'ADDRESS);
X IF stat = 0 THEN
X RAISE CONSTRAINT_ERROR;
X END IF;
X f := Float_type(temp);
X END generic_floating;
X
X -- fixed:
X -- Fixed point types are encoded as uninterpreted bytes.
X PROCEDURE generic_fixed (
X qdrs : IN Handle;
X f : IN OUT Fixed_type
X ) IS
X size,
X maxsize : Integer;
X stat : Integer;
X temp : Q_dep.Address;
X BEGIN
X maxsize := (Fixed_type'SIZE + 7) / 8;
X size := maxsize;
X temp := f'ADDRESS;
X stat := C_qdr_bytes (Q_dep.Address(qdrs), temp'ADDRESS,
X size'ADDRESS, maxsize);
X IF stat = 0 THEN
X RAISE CONSTRAINT_ERROR;
X END IF;
X END generic_fixed;
X
X -- enumeration:
X -- Enumeration types are encoded as integers.
X PROCEDURE generic_enumeration (
X qdrs : IN Handle;
X e : IN OUT Enum_type
X ) IS
X SUBTYPE Enum_Int IS Integer RANGE
X Enum_type'POS(Enum_type'FIRST) ..
X Enum_type'POS(Enum_type'LAST);
X PROCEDURE enumeration IS NEW generic_integer (Enum_Int);
X temp : Enum_Int;
X BEGIN
X temp := Enum_type'POS(e);
X enumeration (qdrs, temp);
X e := Enum_type'VAL(temp);
X END generic_enumeration;
X
X -- boolean:
X -- Special case of enumeration type.
X PROCEDURE bool (
X qdrs : IN Handle;
X b : IN OUT Boolean
X ) IS
X temp,
X stat : Integer;
X BEGIN
X IF b THEN
X temp := 1;
X ELSE
X temp := 0;
X END IF;
X stat := C_qdr_bool (Q_dep.Address(qdrs), temp'ADDRESS);
X IF stat = 0 THEN
X RAISE CONSTRAINT_ERROR;
X END IF;
X b := (temp /= 0);
X END bool;
X
X -- string
X PROCEDURE strings (
X qdrs : IN Handle;
X sp : IN OUT Q.String_ref
X ) IS
X data,
X pointer : Q_dep.Address;
X stat : Integer;
X length,
X maxlen : Integer;
X BEGIN
X IF sp = NULL THEN
X data := Q_dep.NO_ADDR;
X maxlen := Q_dep.MAX_INT;
X length := 0;
X ELSE
X data := sp.ALL'ADDRESS;
X maxlen := sp.ALL'LENGTH;
X length := maxlen;
X END IF;
X pointer := data'ADDRESS;
X stat := C_qdr_bytes (Q_dep.Address(qdrs),
X pointer, length'ADDRESS, maxlen);
X IF stat = 0 THEN
X RAISE CONSTRAINT_ERROR;
X ELSIF sp = NULL THEN
X sp := NEW String(1 .. length);
X stat := C_bcopy (data, sp.ALL'ADDRESS, length);
X C_free (data);
X END IF;
X END strings;
X
X PROCEDURE string_slice (
X qdrs : IN Handle;
X str : IN String
X ) IS
X data,
X pointer : Q_dep.Address;
X stat,
X length,
X maxlen : Integer;
X BEGIN
X data := str'ADDRESS;
X pointer := data'ADDRESS;
X maxlen := str'LENGTH;
X length := maxlen;
X stat := C_qdr_bytes (Q_dep.Address(qdrs),
X pointer, length'ADDRESS, maxlen);
X IF stat = 0 THEN
X RAISE CONSTRAINT_ERROR;
X END IF;
X END string_slice;
X
X -- "raw" data
X PROCEDURE generic_opaque (
X qdrs : IN Handle;
X data : IN OUT Opaque_type
X ) IS
X data_addr,
X pointer : Q_dep.Address;
X stat,
X length,
X maxlen : Integer;
X BEGIN
X data_addr := data'ADDRESS;
X pointer := data_addr'ADDRESS;
X maxlen := (data'SIZE + 7) / 8; -- calculate bytes from bits
X length := maxlen;
X stat := C_qdr_bytes (Q_dep.Address(qdrs),
X pointer, length'ADDRESS, maxlen);
X IF stat = 0 THEN
X RAISE CONSTRAINT_ERROR;
X END IF;
X END generic_opaque;
X
X -- pointer (can be null):
X PROCEDURE generic_pointer (
X qdrs : IN Handle;
X pp : IN OUT Pointer
X ) IS
X more : Boolean;
X BEGIN
X more := pp /= NULL;
X bool (qdrs, more);
X IF more THEN
X IF pp = NULL THEN
X pp := NEW Struct_type;
X END IF;
X struct (qdrs, pp.ALL);
X END IF;
X END generic_pointer;
X
X -- arrays
X PROCEDURE generic_array (
X qdrs : IN Handle;
X a : IN OUT Struct_array
X ) IS
X PROCEDURE int IS NEW generic_integer (Integer);
X length : Integer;
X BEGIN
X length := a'LENGTH;
X int (qdrs, length);
X IF length /= a'LENGTH THEN
X RAISE CONSTRAINT_ERROR;
X END IF;
X FOR i IN a'RANGE LOOP
X struct (qdrs, a(i));
X END LOOP;
X END generic_array;
X
XEND QDR;
END_OF_FILE
if test 8960 -ne `wc -c <'QDR.body.a'`; then
echo shar: \"'QDR.body.a'\" unpacked with wrong size!
fi
# end of 'QDR.body.a'
fi
if test -f 'QDR.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'QDR.c'\"
else
echo shar: Extracting \"'QDR.c'\" \(6651 characters\)
sed "s/^X//" >'QDR.c' <<'END_OF_FILE'
X/*
X** Copyright (c) 1989 by the Regents of the University of California
X** and TRW
X**
X** TITLE: Q: Towards a Multi-lingual Interprocess Communications Model
X**
X** DESCRIPTION:
X**
X** This software represents the first step in an attempt to provide
X** a generalized multi-lingual interprocess communications model.
X** This software provides a consistent set of interfaces for the C
X** and Ada programming languages to permit interprocess communications
X** between processes of either language.
X**
X** AUTHORS: Mark Maybee
X** University of California, Irvine
X**
X** Stephen D. Sykes
X** TRW
X**
X** HISTORY:
X**
X** This software is built on top of the standard XDR/RPC communications
X** model proposed by Sun Microsystems. It also draws heavely from an
X** earlier effort in this area by Mark Maybee and Dennis Heimbigner.
X*/
X
X/*
X * Q Data Representation Support Library
X *
X * This package defines the routine implementations with which
X * to achieve the Q Data Representation (QDR). This
X * representation is based heavily upon the XDR standard.
X *
X * AUTHOR: Mark Maybee CREATION DATE: MAY-1989
X */
X#include "QDR.h"
X#include <values.h>
X
X#define INITIAL_BUFFER_SIZE 512
X#define ENSURE_SPACE(qdrs, l) \
X if (qdrs->x_op == XDR_ENCODE && (l) > qdrs->x_handy) \
X (void) grow_buffer (qdrs, (l));
X
X/*
X * Utility functions
X */
X
Xstatic void
Xgrow_buffer (qdrs, need)
X QDR_Handle qdrs; /* QDR buffer to enlarge */
X u_int need; /* minimum growth required */
X{
X u_int size,
X used;
X char * realloc();
X
X used = ((u_int)qdrs->x_private - (u_int)qdrs->x_base);
X size = used + qdrs->x_handy;
X do {
X size = size << 1;
X } while (size - used < need);
X qdrs->x_private = realloc (qdrs->x_private, size);
X qdrs->x_base = qdrs->x_private + used;
X qdrs->x_handy = size - used;
X}
X
Xenum xdr_op
Xqdr_mode (qdrs)
X QDR_Handle qdrs; /* QDR buffer to enlarge */
X{
X return qdrs->x_op;
X}
X
X/*
X * QDR buffers
X */
X
XQDR_Handle
Xqdr_create()
X{
X QDR_Handle qdrs;
X char *buffer;
X
X qdrs = (QDR_Handle) malloc (sizeof (XDR));
X buffer = (char *) malloc (INITIAL_BUFFER_SIZE);
X xdrmem_create (qdrs, buffer, INITIAL_BUFFER_SIZE, XDR_ENCODE);
X return qdrs;
X}
X
Xvoid
Xqdr_destroy (qdrs)
X QDR_Handle qdrs; /* QDR buffer to destroy */
X{
X char *buf = (char *)qdrs->x_base;
X
X xdr_destroy (qdrs);
X (void) free (buf);
X (void) free ((char *)qdrs);
X}
X
Xvoid
Xqdr_set_write (qdrs)
X QDR_Handle qdrs; /* QDR buffer handle */
X{
X qdrs->x_op = XDR_ENCODE;
X xdr_setpos (qdrs, 0);
X}
X
Xvoid
Xqdr_set_read (qdrs)
X QDR_Handle qdrs; /* QDR buffer handle */
X{
X qdrs->x_op = XDR_DECODE;
X xdr_setpos (qdrs, 0);
X}
X
XQ_Integer
Xqdr_size (qdrs)
X QDR_Handle qdrs; /* QDR buffer handle */
X{
X return ((u_int)qdrs->x_private - (u_int)qdrs->x_base);
X}
X
Xvoid
Xqdr_linearize (qdrs, bp)
X QDR_Handle qdrs; /* QDR buffer handle */
X Q_Strbuf * bp; /* pointer to linearized QDR buffer */
X{
X u_int size;
X void bcopy();
X
X size = ((u_int)qdrs->x_private - (u_int)qdrs->x_base);
X if (bp->data == NULL)
X bp->data = (char *) malloc (size);
X else if (bp->length != size)
X bp->data = (char *) realloc (bp->data, size);
X (void) bcopy (qdrs->x_base, bp->data, (int)size);
X bp->length = size;
X}
X
XQDR_Handle
Xqdr_delinearize (qdrs, b)
X QDR_Handle qdrs; /* QDR buffer handle */
X Q_Strbuf b; /* linearized QDR buffer */
X{
X QDR_Handle handle;
X QDR_Handle qdr_create();
X void grow_buffer(),
X qdr_set_write();
X
X if (qdrs == NULL)
X handle = qdr_create();
X else {
X if (qdrs->x_op != XDR_ENCODE)
X qdr_set_write (qdrs);
X handle = qdrs;
X }
X if (b.length > handle->x_handy)
X grow_buffer (handle, b.length);
X (void) xdr_opaque (handle, b.data, b.length);
X return handle;
X}
X
X
X/*
X * Support for basic scalar types:
X */
X
X/* integer: */
Xbool_t
Xqdr_integer (qdrs, ip)
X QDR_Handle qdrs; /* QDR buffer handle */
X Q_Integer * ip; /* pointer to integer value */
X{
X ENSURE_SPACE (qdrs, sizeof (int))
X return xdr_int (qdrs, (int *)ip);
X}
X
X/* floating: */
Xbool_t
Xqdr_floating (qdrs, fp)
X QDR_Handle qdrs; /* QDR buffer handle */
X Q_Floating * fp; /* pointer to floating value */
X{
X ENSURE_SPACE (qdrs, sizeof (double))
X return xdr_double (qdrs, (double *)fp);
X}
X
X/* boolean: */
Xbool_t
Xqdr_bool (qdrs, bp)
X QDR_Handle qdrs; /* QDR buffer handle */
X Q_Bool * bp; /* pointer to boolean value */
X{
X ENSURE_SPACE (qdrs, sizeof (bool_t))
X return xdr_bool (qdrs, (bool_t *)bp);
X}
X
X/* string (null terminated): */
Xbool_t
Xqdr_string (qdrs, sp, maxsize)
X QDR_Handle qdrs; /* QDR buffer handle */
X char ** sp; /* pointer to string value */
X u_int maxsize; /* maximum alowable string size */
X{
X u_int l;
X char * buffer;
X bool_t stat,
X alloc = 0;
X
X if (qdrs->x_op == XDR_ENCODE) {
X l = strlen (*sp);
X ENSURE_SPACE (qdrs, l)
X }
X else alloc = (*sp == NULL);
X stat = xdr_bytes (qdrs, sp, &l, maxsize);
X if (stat && l < maxsize) {
X if (alloc) {
X buffer = (char *) malloc (l+1);
X (void) bcopy (*sp, buffer, (int)l);
X (void) free (*sp);
X *sp = buffer;
X }
X (*sp)[l] = NULL;
X }
X return stat;
X}
X
X/* generic bytes: */
Xbool_t
Xqdr_bytes (qdrs, bp, lp, maxsize)
X QDR_Handle qdrs; /* QDR buffer handle */
X char ** bp; /* pointer to byte string */
X u_int * lp; /* pointer to length of byte string */
X u_int maxsize; /* maximum alowable string size */
X{
X ENSURE_SPACE (qdrs, *lp)
X return xdr_bytes (qdrs, bp, lp, maxsize);
X}
X
X/* pointer (can be null): */
Xbool_t
Xqdr_pointer (qdrs, bp, size, qdr_struct)
X QDR_Handle qdrs; /* QDR buffer handle */
X char ** bp; /* pointer to data block */
X u_int size; /* size of data block */
X bool_t (*qdr_struct)(); /* QDR procedure to encode structure */
X{
X ENSURE_SPACE (qdrs, sizeof (bool_t))
X return xdr_pointer (qdrs, bp, size, qdr_struct);
X}
X
X/* arrays: */
Xbool_t
Xqdr_array (qdrs, ap, lp, maxsize, elsize, qdr_struct)
X QDR_Handle qdrs; /* QDR buffer handle */
X char ** ap; /* pointer to the array */
X u_int * lp; /* pointer to array length */
X u_int maxsize; /* maximum array size */
X u_int elsize; /* size of array elements */
X bool_t (*qdr_struct) (); /* QDR routine for elements */
X{
X ENSURE_SPACE (qdrs, sizeof (int))
X return xdr_array (qdrs, ap, lp, maxsize, elsize, qdr_struct);
X}
X
X/* buffers: */
Xbool_t
Xqdr_strbuf (qdrs, bp)
X QDR_Handle qdrs; /* QDR buffer handle */
X Q_Strbuf * bp; /* pointer to a QDR buffer */
X{
X u_int maxsize;
X
X ENSURE_SPACE (qdrs, bp->length)
X if (qdrs->x_op == XDR_DECODE) {
X if (bp->data) free (bp->data);
X bp->data = NULL;
X maxsize = MAXINT;
X }
X else maxsize = bp->length;
X return xdr_bytes (qdrs, &bp->data, &bp->length, maxsize);
X}
X
X/* opaque: */
Xbool_t
Xqdr_opaque (qdrs, bp, l)
X QDR_Handle qdrs; /* QDR buffer handle */
X char * bp; /* pointer to byte string */
X u_int l; /* length of byte string */
X{
X ENSURE_SPACE (qdrs, l)
X return xdr_opaque (qdrs, bp, l);
X}
END_OF_FILE
if test 6651 -ne `wc -c <'QDR.c'`; then
echo shar: \"'QDR.c'\" unpacked with wrong size!
fi
# end of 'QDR.c'
fi
if test -f 'QDR.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'QDR.h'\"
else
echo shar: Extracting \"'QDR.h'\" \(3854 characters\)
sed "s/^X//" >'QDR.h' <<'END_OF_FILE'
X/*
X** Copyright (c) 1989 by the Regents of the University of California
X** and TRW
X**
X** TITLE: Q: Towards a Multi-lingual Interprocess Communications Model
X**
X** DESCRIPTION:
X**
X** This software represents the first step in an attempt to provide
X** a generalized multi-lingual interprocess communications model.
X** This software provides a consistent set of interfaces for the C
X** and Ada programming languages to permit interprocess communications
X** between processes of either language.
X**
X** AUTHORS: Mark Maybee
X** University of California, Irvine
X**
X** Stephen D. Sykes
X** TRW
X**
X** HISTORY:
X**
X** This software is built on top of the standard XDR/RPC communications
X** model proposed by Sun Microsystems. It also draws heavely from an
X** earlier effort in this area by Mark Maybee and Dennis Heimbigner.
X*/
X
X/*
X * Q Data Representation Support Library
X *
X * This package defines the routine interfaces with which
X * to achieve the Q Data Representation (QDR). This
X * representation is based heavily upon the XDR standard.
X *
X * AUTHOR: Maybee & Sykes CREATION DATE: JAN-1989
X */
X#ifndef _QDR_SPECIFICATION_
X#define _QDR_SPECIFICATION_
X
X#include <rpc/rpc.h>
X#include "Q.h"
X
X/*
X * QDR buffers
X */
Xtypedef XDR * QDR_Handle;
X
Xextern QDR_Handle qdr_create();
X
Xextern void qdr_destroy ( /*
X QDR_Handle qdrs; -- IN: QDR buffer to destroy
X */ );
X
Xextern void qdr_set_write ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X */ );
X
Xextern void qdr_set_read ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X */ );
X
Xextern Q_Integer qdr_size ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X */ );
X
Xextern void qdr_linearize ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X Q_Strbuf * bp; -- OUT: pointer to linearized QDR buffer
X */ );
X
Xextern QDR_Handle qdr_delinearize ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X Q_Strbuf b; -- IN: linearized QDR buffer
X */ );
X
X
X/*
X * Support for basic scalar types:
X */
X
X/* integer: */
Xextern bool_t qdr_integer ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X Q_Integer * ip; -- IN OUT: pointer to integer value
X */ );
X
X/* floating: */
Xextern bool_t qdr_floating ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X Q_Floating * fp; -- IN OUT: pointer to floating value
X */ );
X
X/* boolean: */
Xextern bool_t qdr_bool ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X Q_Bool * bp; -- IN OUT: pointer to boolean value
X */ );
X
X/* string (null terminated): */
Xextern bool_t qdr_string ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X char ** sp; -- IN OUT: pointer to string value
X u_int maxsize; -- IN: maximum alowable string size
X */ );
X
X/* generic bytes: */
Xextern bool_t qdr_bytes ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X char ** bp; -- IN OUT: pointer to byte string
X u_int * lp; -- IN OUT: pointer to length of byte string
X u_int maxsize; -- IN: maximum alowable string size
X */ );
X
X/* pointer (can be null): */
Xextern bool_t qdr_pointer ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X char ** bp; -- IN OUT: pointer to data block
X u_int size; -- IN: size of data block
X bool_t (*struct)(); -- IN: QDR procedure to encode structure
X */ );
X
X/* arrays: */
Xextern bool_t qdr_array ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X char ** ap; -- IN OUT: pointer to the array
X u_int * lp; -- IN OUT: pointer to array length
X u_int maxsize; -- IN: maximum array size
X u_int elsize; -- IN: size of array elements
X bool_t (*struct)(); -- IN: QDR routine for elements;
X */ );
X
X/* string buffers: */
X/* semantics: qdr_strbuf may be used anywhere qdr_bytes could be used,
X * they will be "re-sized" to the exact size of the incomming
X * string => the buffer data should *only* be allocated via
X * calls to malloc!
X */
Xextern bool_t qdr_strbuf ( /*
X QDR_Handle qdrs; -- IN: QDR buffer handle
X Q_Strbuf * bp; -- IN OUT: pointer to Q string buffer
X */ );
X
X#endif _QDR_SPECIFICATION_
END_OF_FILE
if test 3854 -ne `wc -c <'QDR.h'`; then
echo shar: \"'QDR.h'\" unpacked with wrong size!
fi
# end of 'QDR.h'
fi
if test -f 'Q_dep.a' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Q_dep.a'\"
else
echo shar: Extracting \"'Q_dep.a'\" \(1326 characters\)
sed "s/^X//" >'Q_dep.a' <<'END_OF_FILE'
X--
X-- Copyright (c) 1989 by the Regents of the University of California,
X-- and TRW
X--
X-- TITLE: Q: Towards a Multi-lingual Interprocess Communications Model
X--
X-- DESCRIPTION:
X--
X-- This software represents the first step in an attempt to provide
X-- a generalized multi-lingual interprocess communications model.
X-- This software provides a consistent set of interfaces for the C
X-- and Ada programming languages to permit interprocess communications
X-- between processes of either language.
X--
X-- AUTHORS: Mark Maybee
X-- University of California, Irvine
X--
X-- Stephen D. Sykes
X-- TRW
X--
X-- HISTORY:
X--
X-- This software is built on top of the standard XDR/RPC communications
X-- model proposed by Sun Microsystems. It also draws heavely from an
X-- earlier effort in this area by Mark Maybee and Dennis Heimbigner.
X--
X
X--
X-- Q machine/compiler dependant definitions
X--
X-- This package defines global symbols used throughout
X-- the Q communications model implementation.
X--
X-- AUTHOR: Maybee & Sykes CREATION DATE: JAN-1989
X--
XWITH System;
X
XPACKAGE Q_dep IS
X
X -- types
X
X SUBTYPE Address IS System.Address;
X MAX_INT : CONSTANT := System.MAX_INT;
X NO_ADDR : CONSTANT Address := System.NO_ADDR;
X -- the definition of NULL_ADDR is system dependant and
X -- should be defined as an impossible address.
X
XEND Q_dep;
END_OF_FILE
if test 1326 -ne `wc -c <'Q_dep.a'`; then
echo shar: \"'Q_dep.a'\" unpacked with wrong size!
fi
# end of 'Q_dep.a'
fi
if test -f 'ada.lib' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ada.lib'\"
else
echo shar: Extracting \"'ada.lib'\" \(345 characters\)
sed "s/^X//" >'ada.lib' <<'END_OF_FILE'
X!ada library
XADAPATH= /tmp_mnt/co/ua/gbolcer/ada/procedure_pointer /usr/vads/6.0/verdixlib
XADAPATH= /usr/vads/6.0/standard
Xq:NLPB:Q02:
Xq:BNLPS:Q01:
Xq_dep:NLPB:Q_dep02:
Xq_dep:BNLPS:Q_dep01:
Xqdr:NLPS:QDR01:
Xqdr:NLPB:QDR.body01:
Xprocs:NLPS:procs01:
Xprocs:NLPB:procs.body01:
Xqdr_xref.5B14.call:XILSB:INST24XX:
Xcall:MNLSB:wrap01:
Xcall:XMNLSS:wrap01:
END_OF_FILE
if test 345 -ne `wc -c <'ada.lib'`; then
echo shar: \"'ada.lib'\" unpacked with wrong size!
fi
# end of 'ada.lib'
fi
if test -f 'ada_test.a' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ada_test.a'\"
else
echo shar: Extracting \"'ada_test.a'\" \(900 characters\)
sed "s/^X//" >'ada_test.a' <<'END_OF_FILE'
Xwith Q, QDR, text_io;
XUse Q, QDR, text_io;
X
Xprocedure go is
X
X-- Parameter type for the artist procedure
X type x_type is record
X a: integer := 1;
X b: character := 'b';
X end record;
X type x_ref is access x_type;
X
X-- Pointer to the Parameter type
X procedure qdr_xref is new generic_opaque(x_ref);
X
X-- Variables
X hold: QDR.handle;
X temp, y: x_ref := new x_type;
X
X procedure put_x (name : QDR.Handle) is
X xptr : xref;
X begin
X QDR.set_read(name);
X qdr_xref(name, xptr);
X put(integer'image(xptr.a));
X put(character'image(xptr.b));
X end put_x;
X
X
Xbegin
Xtemp.a := 2;
Xtemp.b := 'c';
Xhold := QDR.create;
XQDR.set_write(hold);
XPut_Line("y:");
Xput_x(y);
XPut_Line("temp:");
Xput_x(temp);
Xqdr_xref(hold, y);
X
X-- somewhere in limbo
X
XQDR.set_read(hold);
Xqdr_xref(hold, temp);
XPut_Line("after");
XPut_Line("y:");
Xput_x(y);
XPut_Line("temp:");
Xput_x(temp);
X
Xend go;
END_OF_FILE
if test 900 -ne `wc -c <'ada_test.a'`; then
echo shar: \"'ada_test.a'\" unpacked with wrong size!
fi
# end of 'ada_test.a'
fi
if test -f 'addcall.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'addcall.c'\"
else
echo shar: Extracting \"'addcall.c'\" \(141 characters\)
sed "s/^X//" >'addcall.c' <<'END_OF_FILE'
X#include <stdio.h>
X#include "QDR.h"
X
Xvoid addcall (fp1, fp2, s)
X void (* fp1) ();
X int* (* fp2) ();
X QDR_Handle s;
X{
X(* fp1)((* fp2)(s));
X}
END_OF_FILE
if test 141 -ne `wc -c <'addcall.c'`; then
echo shar: \"'addcall.c'\" unpacked with wrong size!
fi
# end of 'addcall.c'
fi
if test -f 'gnrx.lib' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'gnrx.lib'\"
else
echo shar: Extracting \"'gnrx.lib'\" \(969 characters\)
sed "s/^X//" >'gnrx.lib' <<'END_OF_FILE'
X!generic library 26
Xwrap:I:qdr_xref.5B14.call:1:C15:642896860:D:generic_opaque.qdr:642895134:642895139#
XQDR.body:B:generic_array.qdr:3:UUC:642895139:642895134#
XQDR.body:I:int.378B13.generic_array.qdr:1:C20:0:G:generic_integer.qdr:642895134:0#
XQDR.body:B:generic_pointer.qdr:2:UC:642895139:642895134#
XQDR.body:B:generic_opaque.qdr:1:U:642895139:642895134#
XQDR.body:B:generic_enumeration.qdr:1:U:642895139:642895134#
XQDR.body:I:enumeration.252B13.generic_enumeration.qdr:1:C20:0:G:generic_integer.qdr:642895134:0#
XQDR.body:B:generic_fixed.qdr:1:U:642895139:642895134#
XQDR.body:B:generic_floating.qdr:1:U:642895139:642895134#
XQDR.body:B:generic_integer.qdr:1:U:642895139:642895134#
XQDR:G:generic_array.qdr:3:UUC:642895134#
XQDR:G:generic_pointer.qdr:2:UU:642895134#
XQDR:G:generic_opaque.qdr:1:U:642895134#
XQDR:G:generic_enumeration.qdr:1:U:642895134#
XQDR:G:generic_fixed.qdr:1:U:642895134#
XQDR:G:generic_floating.qdr:1:U:642895134#
XQDR:G:generic_integer.qdr:1:U:642895134#
END_OF_FILE
if test 969 -ne `wc -c <'gnrx.lib'`; then
echo shar: \"'gnrx.lib'\" unpacked with wrong size!
fi
# end of 'gnrx.lib'
fi
if test -f 'procs.a' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'procs.a'\"
else
echo shar: Extracting \"'procs.a'\" \(507 characters\)
sed "s/^X//" >'procs.a' <<'END_OF_FILE'
Xpackage procs is
X
X type x_type is record
X a: integer := 1;
X b: character := 'b';
X end record;
X type x_ref is access x_type;
X
X----------------------------------------------------------------------
X-- A bunch of procedures that could be used --------------------------
X----------------------------------------------------------------------
X
Xprocedure put1_x (name : x_ref);
X
Xprocedure put2_x (name : x_ref);
X
Xprocedure put3_x (name : x_ref);
X
Xprocedure put4_x (name : x_ref);
X
Xend procs;
END_OF_FILE
if test 507 -ne `wc -c <'procs.a'`; then
echo shar: \"'procs.a'\" unpacked with wrong size!
fi
# end of 'procs.a'
fi
if test -f 'procs.body.a' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'procs.body.a'\"
else
echo shar: Extracting \"'procs.body.a'\" \(906 characters\)
sed "s/^X//" >'procs.body.a' <<'END_OF_FILE'
Xwith text_io; use text_io;
Xpackage body procs is
X
Xprocedure put1_x (name : x_ref) is
X begin
X new_line;
X put_line("procedure 1");
X put(integer'image(name.a));
X new_line;
X put(character'image(name.b));
X new_line;
X end put1_x;
X
Xprocedure put2_x (name : x_ref) is
X begin
X new_line;
X put_line("procedure 2");
X put(integer'image(name.a));
X new_line;
X put(character'image(name.b));
X new_line;
X end put2_x;
X
Xprocedure put3_x (name : x_ref) is
X begin
X new_line;
X put_line("procedure 3");
X put(integer'image(name.a));
X new_line;
X put(character'image(name.b));
X new_line;
X end put3_x;
X
Xprocedure put4_x (name : x_ref) is
X begin
X new_line;
X put_line("procedure 4");
X put(integer'image(name.a));
X new_line;
X put(character'image(name.b));
X new_line;
X end put4_x;
X
Xend procs;
END_OF_FILE
if test 906 -ne `wc -c <'procs.body.a'`; then
echo shar: \"'procs.body.a'\" unpacked with wrong size!
fi
# end of 'procs.body.a'
fi
if test -f 'test.old.a' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'test.old.a'\"
else
echo shar: Extracting \"'test.old.a'\" \(774 characters\)
sed "s/^X//" >'test.old.a' <<'END_OF_FILE'
Xwith Q, QDR, text_io;
XUse Q, QDR, text_io;
X
Xprocedure go is
X
X type x_type is record
X a: integer := 1;
X b: character := 'b';
X end record;
X type x_ref is access x_type;
X
X procedure qdr_xref is new generic_opaque(x_ref);
X hold: QDR.handle;
X temp, y: x_ref := new x_type;
X
X procedure put_x (name : x_ref) is
X begin
X new_line;
X put(integer'image(name.a));
X new_line;
X put(character'image(name.b));
X new_line;
X end put_x;
Xbegin
Xtemp.a := 2;
Xtemp.b := 'c';
Xhold := QDR.create;
XQDR.set_write(hold);
XPut_Line("y:");
Xput_x(y);
XPut_Line("temp:");
Xput_x(temp);
Xqdr_xref(hold, y);
X
X-- somewhere in limbo
X
XQDR.set_read(hold);
Xqdr_xref(hold, temp);
XPut_Line("after");
XPut_Line("y:");
Xput_x(y);
XPut_Line("temp:");
Xput_x(temp);
X
Xend go;
END_OF_FILE
if test 774 -ne `wc -c <'test.old.a'`; then
echo shar: \"'test.old.a'\" unpacked with wrong size!
fi
# end of 'test.old.a'
fi
if test -f 'wrap.a' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'wrap.a'\"
else
echo shar: Extracting \"'wrap.a'\" \(1778 characters\)
sed "s/^X//" >'wrap.a' <<'END_OF_FILE'
X--
X-- Copyright (c) 1990 by the Regents of the University of California,
X--
X-- TITLE: Procedure Pointer Example as Used in Chiron
X--
X-- DESCRIPTION:
X-- This software is an example of how the `Q' functions may be used
X-- to simulate procedure pointers in Ada while hiding the actual
X-- mechanism for accomplishing the call.
X--
X-- AUTHORS: Gregory Alan Bolcer
X-- University of California, Irvine
X--
X--
X-- HISTORY:
X-- This software is built using Q: a multilingual interprocess
X-- communication model. Q here, however is incomplete, and only
X-- the QDR data functions are utilized.
X--
X-- CREATION DATE: May 1, 1990
X--
Xwith QDR, system, text_io, procs; use system, text_io, procs;
X
Xprocedure call is
X
X procedure qdr_xref is new QDR.generic_opaque(x_ref);
X y : x_ref := new x_type;
X type ppointers is access system.address;
X Place : array (1..4) of ppointers ;
X
Xfunction wrap(s: QDR.Handle) return x_ref is
X y: x_ref;
X begin
X QDR.set_read(s);
X qdr_xref(s,y);
X return y;
X end;
X
X procedure addcall(p, w : address ; s : QDR.handle);
X pragma interface (C, addcall);
X pragma interface_name (addcall, "_addcall");
X
Xprocedure eval (t : ppointers; params : in out x_ref) is
X hold: QDR.handle := QDR.create;
X begin
X QDR.set_write(hold);
X qdr_xref(hold, params);
X addcall(t.all, wrap'address, hold);
X end eval;
X
X
Xbegin
XPlace(1) := new system.address'(put1_x'address);
XPlace(2) := new system.address'(put2_x'address);
XPlace(3) := new system.address'(put3_x'address);
XPlace(4) := new system.address'(put4_x'address);
X
X
X Put_Line("before C calls");
X
X put1_x(y);
X eval( Place(1), y );
X
X put2_x(y);
X eval (Place(2), y);
X
X put3_x(y);
X eval (Place(3), y);
X
X put4_x(y);
X eval(Place(4), y);
Xend call;
END_OF_FILE
if test 1778 -ne `wc -c <'wrap.a'`; then
echo shar: \"'wrap.a'\" unpacked with wrong size!
fi
# end of 'wrap.a'
fi
echo shar: End of shell archive.
exit 0