Trailing-Edge
-
PDP-10 Archives
-
bb-r775e-bm_tops20_ks_upd_5
-
sources/dil/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