

; Bliss-32 10.1-416	Monday 21-AUG-1978 19:12:12	DBB3:[RTL.SRC]CERRTS.B32;4					Page 1

;

;	0001	MODULE COM$ERRTST (		! FORTRAN compatibility error test (ERRTST)

;	0002		IDENT = '1-03',		! File: CERRTS.B32

;	0003		LINKAGE (FORTRAN)	! Call-by-reference

;	0004			) =

;	0005	BEGIN

;	0006	

;	0007	!

;	0008	!			  COPYRIGHT (c) 1977 BY

;	0009	!	      DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.

;	0010	!

;	0011	! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED

;	0012	! ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE

;	0013	! INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER

;	0014	! COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY

;	0015	! OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY

;	0016	! TRANSFERRED.

;	0017	!

;	0018	! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE

;	0019	! AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT

;	0020	! CORPORATION.

;	0021	!

;	0022	! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS

;	0023	! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

;	0024	!

;	0025	

;	0026	!++

;	0027	! FACILITY:  FORTRAN compatibility Library

;	0028	!

;	0029	! ABSTRACT:

;	0030	!

;	0031	!	This module contains routine ERRTST to perform F4P-11 type

;	0032	!	compatable error checking.

;	0033	!

;	0034	! ENVIRONMENT:  User Mode - AST re-entrant

;	0035	!

;	0036	! AUTHOR:  Thomas N. Hastings, CREATION DATE:  14-Dec-1977

;	0037	!

;	0038	! MODIFIED BY:

;	0039	!

;	0040	! 	Thomas N. Hastings, 14-Dec-1977: VERSION 0

;	0041	! 00-01	- original

;	0042	! 00-10	- Call back with indirect.  TNH 3-Jan-78.

;	0043	! 00-14	- PSECT F4PCOMPAT$CODE.  TNH 5-Jan-78.

;	0044	! 00-15	- Fix MAXLIM.  TNH 5-Jan-78.

;	0045	! 00-16	- Down count ERROR_COUNT.  TNH 6-Jan-78

;	0046	! 00-17	- Math errors are continue type.  TNH 6-Jan-78

;	0047	! 00-21	- remove debugging printing.  TNH 9-Jan-78

;	0048	!

;	0049	!	Jonathan M. Taylor, 12-Jan-78: VERSION 1

;	0050	! 1-1	- original; break module COM$ERRSET_TST into COM$ERRTST, COM$ERRSET,

;	0051	!	  and COM$$ERRSET_TST.  JMT 12-Jan-78

;	0052	! 1-03	- Change REQUIRE files for VAX system build.  DGP 28-Apr-78

;	0053	!--



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:12:12	DBB3:[RTL.SRC]CERRTS.B32;4					Page 2

;

;	0054	!

;	0055	! TABLE OF CONTENTS:

;	0056	!

;	0057	FORWARD ROUTINE

;	0058		ERRTST: NOVALUE;		! FORTRAN compatibility CALL ERRTST

;	0059	

;	0060	!

;	0061	! INCLUDE FILES:

;	0062	!

;	0063		REQUIRE 'RTLIN:FMAC';			! for DECLARE_PSECTS

; %PRINT:	Filename: FMAC.B32; Version 1, edit 29, TNH, 7-JUN-78

; %PRINT:	 REQUIRE FILE: LPSECT.B32, VERSION 01-5, TNH, 27-Jun-78

;65535  0243		REQUIRE 'RTLML:FERR';			! for FOR$K_MAX_ERR

; %PRINT:	Filename: FERR.MDL! Version 0, edit 36, TNH 19-June-78

;	0361		REQUIRE 'RTLIN:CEST';			! COM$$ERR_TAB fields

; %PRINT:	File: CEST.B32; Version 0, edit 1, JMT 12-Jan-78

;	0400	

;	0401	!

;	0402	! MACROS:

;	0403	!

;	0404	!	None

;	0405	

;	0406	!

;	0407	! EQUATED SYMBOLS:

;	0408	!

;	0409	!	None

;	0410	

;	0411	!

;	0412	! OWN STORAGE:

;	0413	!

;	0414	!	None

;	0415	

;	0416	!

;	0417	! PSECT DECLARATIONS:

;	0418	!

;	0419		DECLARE_PSECTS (F4PCOMPAT);

;	0420	

;	0421	!

;	0422	! EXTERNAL DECLARATIONS:

;	0423	!

;	0424	EXTERNAL

;	0425		COM$$ERR_TAB: BLOCKVECTOR [FOR$K_MAX_ERR + 1, 1, BYTE] ADDRESSING_MODE (GENERAL);



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:12:12	DBB3:[RTL.SRC]CERRTS.B32;4					Page 3

;

;	0426	GLOBAL ROUTINE ERRTST (	! FORTRAN compatibility test error info

;	0427		FORT_ERR_NO,	! Adr. of word containing error number

;	0428		OCCURRED)		! Adr. of word to receive 1 (occurred) or 2 (has not occurred)

;	0429		:NOVALUE =		! No value is returned

;	0430	

;	0431	!++

;	0432	! FUNCTIONAL DESCRIPTION:

;	0433	!

;	0434	!	The ERRTST subroutine tests for the occurrence of a specific

;	0435	!	error during program execution.  FORT_ERR_NO specifies

;	0436	!	the FORTRAN error number and OCCURRED receives:

;	0437	!		1 if error number FORT_ERR_NO has occurred.

;	0438	!		2 if error number FORT_ERR_NO has not occurred

;	0439	!

;	0440	!	since the last CALL ERRTST for that error number.

;	0441	!	Thus the ERRTST subroutine resets the error flag for that

;	0442	!	error.  All error flags are initially 0 when the image is started up.

;	0443	!

;	0444	! FORMAL PARAMETERS:

;	0445	!

;	0446	!	FORT_ERR_NO.rw.r	Adr. of word containing FORTRAN error number

;	0447	!	OCCURRED.ww.r		Adr. of word to received 1 or 2.

;	0448	!

;	0449	! IMPLICIT INPUTS:

;	0450	!

;	0451	!	COM$$ERR_TAB byte table indexed by FORTRAN error number.

;	0452	!

;	0453	! IMPLICIT OUTPUTS:

;	0454	!

;	0455	!	COM$$ERR_TAB byte table.  Occurred flag is cleared for specified error number.

;	0456	!

;	0457	! COMPLETION CODES:

;	0458	!

;	0459	!	NONE

;	0460	!

;	0461	! SIDE EFFECTS:

;	0462	!

;	0463	!	Clears occurred bit in EXTERNAL COM$$ERR_TAB for specified

;	0464	!	FORTRAN error number.

;	0465	!--

;	0466	

;	0467	    BEGIN

;	0468	    MAP

;	0469		FORT_ERR_NO: REF VECTOR [1, WORD],	! Pass word by reference

;	0470		OCCURRED: REF VECTOR [1, WORD];		! Pass word by reference

;	0471	    BUILTIN

;	0472		TESTBITSC;			! Test bit set then clear

;	0473	

;	0474	    !+

;	0475	    ! Test occurred flag for this error then clear it.

;	0476	    ! Return 1 if was set, 2 if was clear.

;	0477	    !-

;	0478	

;	0479	    OCCURRED[0] = (IF TESTBITSC (COM$$ERR_TAB[.FORT_ERR_NO[0], V_EC_OCCURRED]) THEN 1 ELSE 2);

;	0480	    RETURN;



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:12:12	DBB3:[RTL.SRC]CERRTS.B32;4					Page 3-1

;

;	0481	    END;			! End of ERRTST





							    .TITLE  COM$ERRTST

							    .IDENT  \1-03\



							    .EXTRN  COM$$ERR_TAB



							    .PSECT  F4PCOMPAT$CODE,NOWRT,  SHR,  PIC,2



					 0000 00000 	    .ENTRY  ERRTST, Save nothing				      ; 0426

		         50 	  04   BC  3C 00002 	    MOVZWL  @FORT_ERR_NO, R0					      ; 0479

	   05 00000000G0040	       07  E5 00006 	    BBCC    #7, COM$$ERR_TAB[R0], 1$				      ;

		         50 	       01  D0 0000F 	    MOVL    #1, R0						      ;

				       03  11 00012 	    BRB     2$							      ;

		         50 	       02  D0 00014 1$:     MOVL    #2, R0						      ;

		    08   BC	       50  B0 00017 2$:     MOVW    R0, @OCCURRED					      ;

					   04 0001B 	    RET     							      ; 0426



; Routine Size:  28 bytes





;	0482	

;	0483	

;	0484	END

;	0485	ELUDOM













;				       PSECT SUMMARY

;

;	Name		 Bytes			       Attributes

;

;  F4PCOMPAT$CODE 	    28  NOWRT,  RD ,  EXE,  SHR,  LCL,  REL,  CON,  PIC,ALIGN(2)











; Size:		28 code + 0 data bytes

; Run Time:	00:03.1

; Elapsed Time:	00:06.8

; Memory Used:	25 pages

; Compilation Complete

