From:	CRDGW2::CRDGW2::MRGATE::"SMTP::CRVAX.SRI.COM::RELAY-INFO-VAX" 12-JUL-1989 09:38
To:	MRGATE::"ARISIA::EVERHART"
Subj:	Re: [How to avoid] "If (.not. status) Call Lib$Signal (%Val (Status))"

Message-Id:  <8907121332.AA25202@crdgw1.ge.com>
Received: From KL.SRI.COM ([0.0.0.0]) by CRVAX.SRI.COM with TCP; Wed, 12 JUL 89 05:33:01 PDT
Received: from NSFnet-Relay.AC.UK by KL.SRI.COM with TCP; Wed, 12 Jul 89 05:13:44 PDT
Received: from vaxa.rhbnc.ac.uk by NSFnet-Relay.AC.UK   via Janet with NIFTP
           id aa04417; 12 Jul 89 12:24 BST
Date: 		Wed, 12 JUL 89 12:35:21 BST
From: CHAA006%vaxa.rhbnc.ac.uk@NSFnet-Relay.AC.UK
To: Info-Vax <@NSFnet-Relay.AC.UK:Info-Vax@kl.sri.com>
Subject:        Re: [How to avoid] "If (.not. status) Call Lib$Signal (%Val (Status))"
Sender: "JANET CHAA006@UK.AC.RHBNC.VAXA" <CHAA006%vaxa.rhbnc.ac.uk@NSFnet-Relay.AC.UK>
Reply-To: Philip Taylor (RHBNC) <P.Taylor%vaxb.rhbnc.ac.uk@NSFnet-Relay.AC.UK>
Originally-To:  JANET%"Sysmgr@Kcl.Ph.Ipg",$INFO-VAX
Mailer:         Janet_Mailshr V3.4 (23-May-1989)

Nigel Arnot <Sysmgr@Ipg.Ph.Kcl.Ac.Uk> has recently suggested how one might
avoid the tiresome repetition of 

	If (.not. status) call lib$signal (%val (status)) 

Here is another approach (sadly uncommented, in my usual style), which has the
advantage of keeping the error condition available for future analysis.
Routines omitted include `integer function close', `integer function parse',
etc. 

					Philip Taylor
			    Royal Holloway and Bedford New College.

================================================================================

	if (function (lib$get_lun (unit)))
     &	then
	    if (function (open (unit, filename)))
     &	    then
	        result = parse (unit, header)
		call close (unit)
	    else
	    	result = status ()
	    end if
	    call function (lib$free_lun (unit))
	else
	    result = status ()
	end if
	if (result) 
     &	then
	    analyse = result
    	else
	    call lib$signal (cbs$_errduranl, %val (1), 
     &				filename, %val (result))
    	    analyse = result .or. sts$m_inhib_msg
    	end if
	return
	end

	integer function open (unit, filename)
	implicit none
	include '($ssdef)'
	character * (*) filename
	integer unit, cbs$sig_and_ret
	external cbs$sig_and_ret
	call lib$establish (cbs$sig_and_ret)
	open (unit=unit, file=filename, status='old', readonly, shared)
	open = ss$_normal
	return
	end

	integer function function (condition)
	implicit none
	include '($ssdef)'
	include '($stsdef)'
	integer status, condition, previous_condition
	common /own/ previous_condition
	data previous_condition /ss$_normal/
	if (.not. condition) 
     &	then
	    call lib$signal (%val(condition))
	    previous_condition = condition .or. sts$m_inhib_msg
    	else
	    previous_condition = condition
	end if
	function = previous_condition
	return
	entry status ()
	status = previous_condition
	return
	end

	integer function cbs$err_handler (signal, mechanism)
	implicit none
	include '($ssdef)'
	include '($chfdef)'
	include '($stsdef)'
	integer op_routine, seq_number, cbs$_oproutine, lib$match_cond
	structure /extdef1/
		record /chfdef1/ main
		integer chf$l_rtn_addr, chf$l_seq_nmbr
	end structure
	record /extdef1/ signal
	record /chfdef2/ mechanism
	external cbs$_oproutine
	data op_routine /0/
C
C --- Check for condition handler initialisation entry, 
C --- used to establish o/p routine and sequence number
C
	if (lib$match_cond (signal.main.chf$l_sig_name,
     &				%ref(%loc(cbs$_oproutine))) .eq. 1)
     &	then
		op_routine = signal.chf$l_rtn_addr
		seq_number = signal.chf$l_seq_nmbr
	else
		call cbs$putmsg(signal, %val(op_routine),
     &					%val(seq_number))
	end if
	cbs$err_handler = ss$_continue
	return
	end

	integer function cbs$sig_and_ret (signal, mechanism)
	implicit none
	include '($ssdef)'
	include '($chfdef)'
	include '($stsdef)'
	integer lib$match_cond
	record /chfdef1/ signal
	record /chfdef2/ mechanism
	external lib$signal
	if (lib$match_cond (signal.chf$l_sig_name, ss$_unwind) .ne. 1)
     &	then
	    call cbs$re_signal (signal)
	    if ((signal.chf$l_sig_name .and. sts$m_severity) 
     &		    .gt. sts$k_success)
     &			call lib$sig_to_ret (signal, mechanism)
	else
	    continue
	end if
	cbs$sig_and_ret = ss$_continue
	return
	end	

	subroutine cbs$re_signal (signal)
	implicit none
	include '($chfdef)'
	include '($stsdef)'
	integer lib$signal
	record /chfdef1/ signal
	external lib$signal
	signal.chf$l_sig_args = signal.chf$l_sig_args - 2
	call lib$callg (signal, lib$signal)
	signal.chf$l_sig_args = signal.chf$l_sig_args + 2
	signal.chf$l_sig_name = signal.chf$l_sig_name 
     &					.or. sts$m_inhib_msg
	return
	end

	subroutine cbs$putmsg (signal, callback, seq_number)
	implicit none
	include '($chfdef)'
	integer callback, seq_number
	record /chfdef1/ signal
	signal.chf$l_sig_args = signal.chf$l_sig_args - 2
	call sys$putmsg (signal, callback, 'CBS', seq_number)
	signal.chf$l_sig_args = signal.chf$l_sig_args + 2
	return
	end

