Google
 

Trailing-Edge - PDP-10 Archives - cuspbinsrc_1of2_bb-x128c-sb - 10,7/dil/dilsrc/dilint.bli
There are 21 other files named dilint.bli in the archive. Click here to see a list.
%title 'DIL interface routines'

MODULE dilint

!  COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1983, 1986.
!  ALL RIGHTS RESERVED.
!  
!  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY  BE  USED  AND
!  COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
!  THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE.   THIS  SOFTWARE  OR
!  ANY  OTHER  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
!  AVAILABLE TO ANY OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE
!  SOFTWARE IS HEREBY TRANSFERRED.
!  
!  THE INFORMATION IN THIS SOFTWARE IS  SUBJECT  TO  CHANGE  WITHOUT
!  NOTICE  AND  SHOULD  NOT  BE CONSTRUED AS A COMMITMENT BY DIGITAL
!  EQUIPMENT CORPORATION.
!  
!  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF
!  ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.

!++
! .chapter DILINT
!
!   The module DILINT contains the few interface routines common between
! DIX and DIT.  These all relate to the kludge for COBOL programs to
! receive return status values.
!
!   FACILITY: Data Interchange Library (DIL)
!
!   ABSTRACT:
!
!   ENVIRONMENT:
!
!   AUTHOR: David Dyer-Bennet, Creation Date: 12-Jul-82
!--

    (IDENT = '2.1(141)'                 ! \.p;\ [8] 
                                        ! **EDIT**
    %REQUIRE ('DILSWI.REQ')             ! [%O'73']  [change diXswi to diLswi]
%BLISS36 (
    , ENTRY  (                          ! ;  Entry symbols:
        diluih, dilret, dilini          ! \
    )
)
) =
BEGIN

%SBTTL 'Declarations'

!++
! .hl 1 Require files
!--

REQUIRE 'DIXREQ.REQ';                   ! \

!++
! .hl 1 Library files
!--

%sbttl 'Edit History'                   ! [8] Add this entire subsection

!++
! .hl 1 Edit History
!--

LIBRARY 'VERSION';

! ; .autotable

!++ COPY 

new_version (1, 0)

edit (8, '23-Aug-82', 'David Dyer-Bennet')
 %( Change version and revision standards everywhere.
    Files: All. )%

edit (10, '22-Sep-82', 'David Dyer-Bennet')
 %( Always use long_relative addressing on VAX. )%

Edit (%O'46', '19-Jan-83', 'David Dyer-Bennet')
 %( Update copyright notice, mark end of edit histories.
 )%

Edit (%O'73', '19-May-83', 'David Dyer-Bennet')
 %( Add DILSWI require file to headings of all modules.  DILSWI
    contains the BLISS32 addressing-mode declarations and the TOPS-10
    OTS declaration to avoid invoking the losing default of .REQUESTING
    the OTS library from whatever directory the compiler was called from
    when the build ran.
 )%

Edit (%O'74', '8-June-83', 'Charlotte L. Richardson')
 %( Declare version 1 complete.  All modules.
 )%

new_version (1, 1)

new_version (2, 0)

Edit (%O'75', '12-Apr-84', 'Sandy Clemens')
 %( Put all Version 2 DIL development files under edit control.  Some
    of the files listed below have major code edits, or are new
    modules.  Others have relatively minor changes, such as cleaning
    up a comment.
    FILES:  COMPDL.CTL, DIL.RNH, DIL2VAX.CTL, DILBLD.10-MIC,
    DILHST.BLI, DILINT.BLI, DILOLB.VAX-COM, DILV6.FOR, DILV7.FOR,
    INTERFILS.CTL, MAKDIL.CTL, MASTER-DIL.CMD, POS20.BLI, POSGEN.BLI,
    DLCM10.10-CTL, DLMK10.10-CTL
 )%

Edit (%O'134', '8-Oct-84', 'Sandy Clemens')
  %( Add new format of COPYRIGHT notice.  FILES:  ALL )%

new_version (2, 1)

Edit (%O'141', '1-Jun-86', 'Sandy Clemens')
  %( Add DIL sources to DL21: directory. )%

! **EDIT**

!-- .autoparagraph

mark_versions ('DIL')
!++
! .hl 1 Debugging declarations
!--

dix$module_debug (off);                 ! \

!++
! .hl 1 Own storage
!--

! [8] Remove version number stuff (now located above)

!++
! .hl 2 Return value kludges
! .index Return value kludges
!   To make the status values returned more palatable to higher-level
! language programs, and indeed to make them accessible to COB36 programs
! at all, some tinkering was required.
!
!   COB36 doesn't handle function values.  Other higher level languages do
! not have the easiest time breaking down bit-packed integers.  Therefore,
! we have provided for the same information returned in the status value
! to be returned broken down.
!
!  For consistency, this is available on the 20 and on the VAX.
!--

OWN
    !++
    !   Use of these makes the DIX package non-reentrant.  They are only used
    ! by programs which call DILINI.
    !--
    dil$gg_return_stat_val : INITIAL (0) VOLATILE,       ! \.P;>\
                                        ! ; Holds ADR to return stat val in.
    dil$gg_return_msg_id : INITIAL (0) VOLATILE,		! \.p;>\
    					! ; Holds ADR to return msg-id in.
    dil$gg_return_severity : INITIAL (0) VOLATILE;       ! \.p;>\
                                        ! ; Holds ADR to return severity in.

!++
! .hl 1 Global data
!--

!++
! .hl 1 External references
!--

%BLISS36 (                              ! .HL 2 If bliss36
EXTERNAL ROUTINE                        ! ;   External routines:
                                        ! ;.s 1.list 0, 'o'
!++ copy /strip .le;
    dix$$get_argadr
!-- .end list
;
)
%SBTTL 'GLOBAL ROUTINE dil$$return_kludge'

GLOBAL ROUTINE dil$$return_kludge	! \.!=;.hl 1 \
! ; .index  dil$$return_kludge

!++
!   If the module OWN variables dil$gg_return_sta_val, dil$gg_return_severity,
! and dil$gg_return_msg_id are filled in, put the status value passed by our
! caller into them.  In any case return it as our value.
!
!   Routine Value:  Status value passed as CALLER_STATUS is returned as routine
! value.
! 
!   Side effects / implicit arguments:
! .list 0, "o"
! .le;dil$gg_return_stat_val 0, or address to put status in
! .le;dil$gg_return_msg_id 0, or address to message id in
! .le;dil$gg_return_severity 0, or address to put severity in
! .end list
!
!   Formal arguments:
! .list 1
!--
    (
    caller_status                       ! \.le;\: Status value to be 
                                        ! ; returned by our caller.
    ) =                                 ! ; .end list
BEGIN

MAP
    caller_status : condition_value;

dix$routine_debug (on);                 ! [2] Change default to on

debug_code (                            ! ; .P;If debug set,
    tty_put_quo ('Kludge entry: ');     ! ; print caller status on terminal.
    stsdmp (caller_status);
    );

IF .dil$gg_return_stat_val NEQA 0 THEN .dil$gg_return_stat_val = .caller_status;

IF .dil$gg_return_severity NEQA 0 THEN .dil$gg_return_severity = .caller_status [sts$v_severity];

IF .dil$gg_return_msg_id NEQA 0 THEN
    BEGIN                               ! [2] Replace old action on msg-id with correct code
    LOCAL                               ! [2]
        temp_cond: condition_value;     ! [2]
    temp_cond = 0;                      ! [2]
    IF .caller_status [sts$v_fac_sp] THEN       ! [2]
        temp_cond [sts$v_cond_id] = .caller_status [sts$v_cond_id]      ! [2]
    ELSE                                ! [2]
        temp_cond [sts$v_code] = .caller_status [sts$v_code];   ! [2]
    .dil$gg_return_msg_id = .temp_cond; ! [2]
    dtype (on, 'Msg id returned = ', .temp_cond);       ! [2]
    END;                                ! [2]
.caller_status                      ! \.P;Always return \ as our value.
END;				! END OF dil$$return_kludge
%SBTTL 'GLOBAL ROUTINE dil$$usr_intrfc_hand'
GLOBAL ROUTINE dil$$usr_intrfc_hand     ! \.!=;.hl 1 \
! ; .index  dil$$usr_intrfc_hand     

!++
!   By convention, this handler should be enabled by any user interface
! routine -- one called directly by user code. (Portal routines to
! the DIX have another handler, below.)
!
!   This handler traps any signals that get up this high and
! returns them to the user routine calling the enabling routine as the
! function return value (if any).  This prevents errors from being
! "lost" in the sense of not being reported to the user.
!
!   This handler is aware of the COB36 function value return
! kludge (see description above).
!
!   SCH:  Level = 2
!
!   Routine Value:
! Information for CHF, as described in BLISS condition handling
! documentation.
!
!   Implicit parameters / side effects:
! See dil$$return_kludge above.
!
!   Formal arguments:
! .list 1
!--
    (
        sig_vec,                        ! \.le;>\: Signal vector, as
                                        ! ; described in BLISS condition
                                        ! ; handling documentation.
        mech_vec,                       ! \.le;>\: Mechanism vector, as
                                        ! ; described in BLISS condition
                                        ! ; handling documentation.

        enabl_vec                       ! \.le;>\: Enable vector, as
                ! ; described in BLISS condition handling
                ! ; documentation.  The first parameter
                ! ; specified by the enabler is a local data
                ! ; segment in the enabler that can be used
                ! ; for temporary storage of error
                ! ; information.
    ) =                                 ! ; .end list

    BEGIN

    MAP
	sig_vec : REF VECTOR,
	mech_vec : REF VECTOR,
	enabl_vec : REF VECTOR;

    BIND
	cond = sig_vec [1] : condition_value,
	return_value = mech_vec [ %BLISS16 (1) %BLISS36 (1) %BLISS32 (3)],
	error_temp = .enabl_vec [1] : condition_value;

    dix$routine_debug (on);             ! [2] Change default to on

! ; .hl 2 Code flow

    IF .cond NEQ dix$unwind_cond        ! ;   If we are not unwinding,
    THEN
	BEGIN
	error_temp = .cond;             ! ; store away condition for later.
	dil$$return_kludge (.cond);     ! ; Set kludge return locations now.
	SETUNWIND ()                    ! ; Signal an unwind.
	END
    ELSE                                ! ;   If unwinding,
	return_value = .error_temp      ! ; return stored condition value.

    END;				! END OF dil$$usr_intrfc_hand
%SBTTL 'GLOBAL ROUTINE DIL$INIT'

GLOBAL ROUTINE dil$init                 ! \.!=;.hl 1 \
! ; .index dil$init

!++
! 
!   SCH:  Level = 1, DD = 3.  User interface routine.  
!
!   This is essentially a hack to let programs see the status information
! in a COBOL-oriented way.  It need
! not be called if the language you are using allows you to pick up the
! return status value produced by the functions you call.
! 
!   Algorithm:  Store away address provided in global storage.
! 
!   Implicit Parameters/side effects:
! .s 1.list 1
! .le;dil$gg_return_sTAT_VAL Module OWN location in which to store value of
! STATUS_LOC.
! 
! .le;dil$gg_return_msg_id Module OWN location in which to store message id.
!
! .le;dil$gg_return_sEVERITY Module OWN location in which to store value of
! SEVERITY_LOC.
! .end list
! 
!   Routine Value:
! 
! NONE.
!   
! Formal arguments:
!--
    (                               ! ; .s 1.list 1
	status_value,               ! \.le;\: (by ref, written) Status value.
	stat_loc,                   ! \.le;\: Addr where other interface
				    ! ; routines will return their
				    ! ; function values.
	mid_loc,			! \.le;\: Addr where other user interface
				    ! ; routines will return message id.
	severity_loc                ! \.le;\: Addr where other user
				    ! ; interface routines will return
				    ! ; the severity portion of their
				    ! ; status codes.
    ) :                             ! ; .end list

    FORTRAN_FUNC                    ! \.P;Linkage \ used.
    NOVALUE =

BEGIN
BUILTIN ACTUALCOUNT;
IF ACTUALCOUNT () GTR 1 THEN
    BEGIN
    dil$gg_return_stat_val = argadr (.stat_loc);
    IF ACTUALCOUNT () GTR 2 THEN
	BEGIN
	dil$gg_return_msg_id = argadr (.mid_loc);
	IF ACTUALCOUNT () GTR 3 THEN
	    BEGIN
	    dil$gg_return_severity = argadr (.severity_loc);
	    END
	END
    END;
.status_value = dix$success_cond;	! ; This routine always returns dix$success_cond.
END;                                    ! END OF dix$$dilini

eND					! End of module

ELUDOM