From:	CRDGW2::CRDGW2::MRGATE::"SMTP::CRVAX.SRI.COM::RELAY-INFO-VAX" 26-JUN-1989 16:45
To:	MRGATE::"ARISIA::EVERHART"
Subj:	How to avoid  IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))

Message-Id:  <8906262032.AA07018@crdgw1.ge.com>
Received: From KL.SRI.COM by CRVAX.SRI.COM with TCP; Mon, 26 JUN 89 12:15:24 PDT
Received: from CUNYVM.CUNY.EDU by KL.SRI.COM with TCP; Mon, 26 Jun 89 12:07:05 PDT
Received: from UKACRL.BITNET by CUNYVM.CUNY.EDU (IBM VM SMTP R1.1) with BSMTP id 4654; Mon, 26 Jun 89 14:52:19 EDT
Received: from RL.IB by UKACRL.BITNET (Mailer X1.25) with BSMTP id 6495; Mon,
 26 Jun 89 18:13:35 BST
Received: from RL.IB by UK.AC.RL.IB (Mailer X1.25) with BSMTP id 4306; Mon, 26
          Jun 89 18:13:34 BS
Via:      UK.AC.KCL.PH.IPG; 26 JUN 89 18:13:29 BST
Date:     26-JUN-1989 18:13:27 GMT
From: SYSMGR%IPG.PH.KCL.AC.UK@CUNYVM.CUNY.EDU
To: info-vax@KL.SRI.COM
Subject:  How to avoid  IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))
Sender: JANET "SYSMGR@UK.AC.KCL.PH.IPG" (Nigel Arnot) <SYSMGR@IPG.PH.KCL.AC.UK>

It's been a while since I submitted anything. The following is the answer
for anyone who is getting fed up with inserting

    IF( .NOT.STATUS) CALL LIB$SIGNAL( %VAL( STATUS))

in their programs. The comments at the top of CALLVMS.MAR should make things
clear; CALLVMSTEST.FOR was used while I was testing it, and also as an example.

                Nigel Arnot
                (NRA%KCL.PH.IPG@UKACRL.BITNET)

PS apologies if someone else posted similar recently, my infovax is about two
weeks delayed at present!


$! ................... Cut between dotted lines and save. ...................
$!...........................................................................
$! VAX/VMS archive file created by VMS_SHARE V06.10A 3-MAR-1989.
$!
$! VMS_SHARE was written by James Gray (Gray:OSBUSouth@Xerox.COM) from
$! VMS_SHAR by Michael Bednarek (U3369429@ucsvc.dn.mu.oz.au).
$!
$! To unpack, simply save, concatinate all parts into one file and
$! execute (@) that file.
$!
$! This archive was created by user SYSMGR
$! on 22-JUN-1989 13:51:30.10.
$!
$! It contains the following 2 files:
$!        CALLVMS.MAR
$!        CALLVMSTEST.FOR
$!
$!============================================================================
$ SET SYMBOL/SCOPE=( NOLOCAL, NOGLOBAL )
$ VERSION = F$GETSYI( "VERSION" )
$ IF VERSION .GES "V4.4" THEN GOTO VERSION_OK
$ WRITE SYS$OUTPUT "You are running VMS ''VERSION'; ", -
    "VMS_SHARE V06.10A 3-MAR-1989 requires VMS V4.4 or higher."
$ EXIT 44 ! SS$_ABORT
$VERSION_OK:
$ GOTO START
$!
$UNPACK_FILE:
$ WRITE SYS$OUTPUT "Creating ''FILE_IS'"
$ DEFINE/USER_MODE SYS$OUTPUT NL:
$ EDIT/TPU/COMMAND=SYS$INPUT/NODISPLAY/OUTPUT='FILE_IS'/NOSECTION -
    VMS_SHARE_DUMMY.DUMMY
b_part := CREATE_BUFFER( "$Part", GET_INFO( COMMAND_LINE, "file_name" ) )
; s_file_spec := GET_INFO( COMMAND_LINE, "output_file" ); SET( OUTPUT_FILE
, b_part, s_file_spec ); b_errors := CREATE_BUFFER( "$Errors" ); i_errors
:= 0; pat_beg_1 := ANCHOR & "-+-+-+ Beginning"; pat_beg_2 := LINE_BEGIN
& "+-+-+-+ Beginning"; pat_end := ANCHOR & "+-+-+-+-+ End"; POSITION
( BEGINNING_OF( b_part ) ); LOOP EXITIF SEARCH( SPAN( ' ' )@r_trail
& LINE_END, FORWARD) = 0; POSITION( r_trail ); ERASE( r_trail ); ENDLOOP
; POSITION( BEGINNING_OF( b_part ) ); i_append_line := 0; LOOP EXITIF MARK
( NONE ) = END_OF( b_part ); s_x := ERASE_CHARACTER( 1 )
; IF s_x = '+' THEN r_skip := SEARCH( pat_beg_1, FORWARD, EXACT ); IF r_skip
<> 0 THEN s_x := ''; MOVE_HORIZONTAL( -CURRENT_OFFSET ); ERASE_LINE; ENDIF
; ENDIF; IF s_x = '-' THEN r_skip := SEARCH( pat_end, FORWARD, EXACT )
; IF r_skip <> 0 THEN s_x := ''; MOVE_HORIZONTAL( -CURRENT_OFFSET ); m_skip
:= MARK( NONE ); r_skip := SEARCH( pat_beg_2, FORWARD, EXACT ); IF r_skip
<> 0 THEN POSITION( END_OF( r_skip ) ); MOVE_HORIZONTAL( -CURRENT_OFFSET )
; MOVE_VERTICAL( 1 ); MOVE_HORIZONTAL( -1 ); ELSE POSITION( END_OF( b_part
) ); ENDIF; ERASE( CREATE_RANGE( m_skip, MARK( NONE ), NONE ) ); ENDIF; ENDIF
; IF s_x = 'V' THEN s_x := ''; IF i_append_line <> 0 THEN APPEND_LINE
; MOVE_HORIZONTAL( -CURRENT_OFFSET ); ENDIF; i_append_line := 1
; MOVE_VERTICAL( 1 ); ENDIF; IF s_x = 'X' THEN s_x := ''; IF i_append_line
<> 0 THEN APPEND_LINE; MOVE_HORIZONTAL( -CURRENT_OFFSET ); ENDIF
; i_append_line := 0; MOVE_VERTICAL( 1 ); ENDIF; IF s_x <> '' THEN i_errors
:= i_errors + 1; s_text := CURRENT_LINE; POSITION( b_errors ); COPY_TEXT
( "The following line could not be unpacked properly:" ); SPLIT_LINE
; COPY_TEXT( s_x ); COPY_TEXT( s_text ); POSITION( b_part ); MOVE_VERTICAL
( 1 ); ENDIF; ENDLOOP; POSITION( BEGINNING_OF( b_part ) ); LOOP r_x := SEARCH
( "`", FORWARD, EXACT ); EXITIF r_x = 0; POSITION( r_x ); ERASE_CHARACTER
( 1 ); COPY_TEXT( ASCII( INT( ERASE_CHARACTER( 3 ) ) ) ); ENDLOOP
; IF i_errors = 0 THEN SET( NO_WRITE, b_errors, ON ); ELSE POSITION
( BEGINNING_OF( b_errors ) ); COPY_TEXT( FAO
( "The following !UL errors were detected while unpacking !AS", i_errors
, s_file_spec ) ); SPLIT_LINE; SET( OUTPUT_FILE, b_errors, "SYS$COMMAND" )
; ENDIF; EXIT;
$ DELETE VMS_SHARE_DUMMY.DUMMY;*
$ CHECKSUM 'FILE_IS
$ WRITE SYS$OUTPUT " CHECKSUM ", -
  F$ELEMENT( CHECKSUM_IS .EQ. CHECKSUM$CHECKSUM, ",", "failed!!,passed." )
$ RETURN
$!
$START:
$ FILE_IS = "CALLVMS.MAR"
$ CHECKSUM_IS = 1954109594
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
X;
X; This routine is used to make a call of a system service or RTL routine,
X; followed by a check on the status code returned. If this indicates
X; trouble, the error is signalled.
X;
X; Example: the following code
X;
X;`009INTEGER SYS$ASSIGN, TTCHAN
X;`009...
X;`009ISTAT = SYS$ASSIGN( 'TT:', TTCHAN, , )
X;`009IF( .NOT.ISTAT) CALL LIB$SIGNAL( %VAL( ISTAT))
X;
X; can be replaced by
X;
X;`009EXTERNAL SYS$ASSIGN
X;`009INTEGER TTCHAN
X;
X;`009CALL CALLVMS( SYS$ASSIGN, 'TT:', TTCHAN, , )
X; `009
X; The first argument must be declared EXTERNAL (or the non-FORTRAN equivalent
V; in other languages). THe other arguments can be of any type and use whateve
Xr
X; passing mechanisn is required by the first argument.
X;
X; If CALLVMS is used as a function, it returns any non-error status returned
X; by the called routine.
X;
X`009.TITLE CALLVMS
X`009.IDENT /V01/
X`009.PSECT`009CODE`009RD,NOWRT,EXE
X
X`009.ENTRY`009CALLVMS, `094M<>
X;
X; first part: copy args N down to 2 onto the stack. It's tempting just to
V; zap the first argument and restore it afterwards, but it is not inconcievab
Xle
X; that an argument list is in a read-only PSECT.
X;
X`009MOVZBL`009(AP),R1`009`009`009; get argument count
X`009MOVAL`0094(AP)`091R1`093,R0`009`009; base address of last argument
X`009`009`009`009`009; plus 4 (is pre-decremented in loop)
X`009DECL`009R1`009`009`009; decrement
X`009BEQL`00910$`009`009`009; nothing to copy?
X
X5$:`009MOVL`009-(R0),-(SP)`009`009;copy args to stack
X`009SOBGTR`009R1,5$
X
X`009SUBB3`009#1,(AP),R1`009`009;retrieve argcount-1
X10$:`009CALLS`009R1,@4(AP)`009`009;call user routine
X`009BLBS`009R0,90$`009`009`009;OK?
X
X`009PUSHL`009R0`009`009`009; NO, signal problem
X`009CALLS`009#1,G`094LIB$SIGNAL
X
X90$:`009RET
X`009.END
$ GOSUB UNPACK_FILE

$ FILE_IS = "CALLVMSTEST.FOR"
$ CHECKSUM_IS = 458061297
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
X`009EXTERNAL SYS$ASSIGN, TEST4
X
X`009CALL CALLVMS( TEST4, 1, 2, '3', '4')
X
X`009WRITE(6,*) 'Should be OK'
X`009CALL CALLVMS (SYS$ASSIGN, 'TT:', TTCHAN ,,)
X
X`009WRITE(6,*) 'Should be no-such-device'
X`009CALL CALLVMS( SYS$ASSIGN, 'XXX', XXCHAN ,,)
X
X`009WRITE(6,*) 'Should be insfarg'
X`009CALL CALLVMS( SYS$ASSIGN, 'TT:', TTT)
X
X`009STOP
X`009END
X
X`009INTEGER FUNCTION TEST4( I,J,C,CC)
X`009CHARACTER *(*) C,CC
X
X`009WRITE(6,*) 'TEST4 entered OK'
X`009WRITE(6,*) I,J,C,CC
X
X`009TEST4 = 1
X`009RETURN
X`009END
$ GOSUB UNPACK_FILE
$ EXIT

