

; Bliss-32 10.1-416	Monday 21-AUG-1978 19:11:48	DBB3:[RTL.SRC]CERRSE.B32;7					Page 1

;

;	0001	MODULE COM$ERRSET (		! FORTRAN compatibility error set (ERRSET)

;	0002		IDENT = '1-06',		! File: CERRSE.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 ERRSET 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-3	- Bug fix.  Call SIG_NO_LUB, not SIGNAL_STOP.  JMT 8-Apr-78

;	0053	! 1-04	- Change to STARLET library. DGP 20-Apr-78

;	0054	! 0-05	- Change REQUIRE files for VAX system build.  DGP 28-Apr-78

;	0055	! 1-06	- Change STARLET to RTLSTARLE to avoid conflicts.  DGP 1-May-78



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:11:48	DBB3:[RTL.SRC]CERRSE.B32;7					Page 1-1

;

;	0056	!--



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:11:48	DBB3:[RTL.SRC]CERRSE.B32;7					Page 2

;

;	0057	!

;	0058	! TABLE OF CONTENTS:

;	0059	!

;	0060	FORWARD ROUTINE

;	0061		ERRSET: NOVALUE;		! FORTRAN compatibility CALL ERRSET

;	0062	

;	0063	!

;	0064	! INCLUDE FILES:

;	0065	!

;	0066		LIBRARY	'RTLSTARLE';		! STARLET library for macros and symbols

;	0067		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  0247		REQUIRE 'RTLML:FERR';			! for FOR$K_MAX_ERR

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

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

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

;	0404	

;	0405	!

;	0406	! MACROS:

;	0407	!

;	0408	!	None

;	0409	

;	0410	!

;	0411	! EQUATED SYMBOLS:

;	0412	!

;	0413	!	None

;	0414	

;	0415	!

;	0416	! OWN STORAGE:

;	0417	!

;	0418	!	None

;	0419	

;	0420	!

;	0421	! PSECT DECLARATIONS:

;	0422	!

;	0423		DECLARE_PSECTS (F4PCOMPAT);

;	0424	

;	0425	!

;	0426	! EXTERNAL REFERENCES:

;	0427	!

;	0428	EXTERNAL

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

;	0430		COM$$ERRORCOUNT: ADDRESSING_MODE (GENERAL);		! Image error count limit.

;	0431						! Decremented by COM_HANDLER.

;	0432						! EXIT on continuable error if 0.

;	0433	

;	0434	EXTERNAL ROUTINE

;	0435		FOR$$SIG_NO_LUB: NOVALUE ADDRESSING_MODE (GENERAL);

;	0436						! SIGNAL_STOP FORTRAN error with no

;	0437						! LUB associated.



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:11:48	DBB3:[RTL.SRC]CERRSE.B32;7					Page 3

;

;	0438	GLOBAL ROUTINE ERRSET (	! FORTRAN compatibility set error control

;	0439		FORT_ERR_NO,	! Adr. of word containing FORTRAN error number

;	0440		CONTIN,		! Adr. of word containing continue flag

;	0441		COUNT,		! Adr. of word containing count flag

;	0442		CONT_TYPE,		! Adr. of word containing continue type

;	0443		LOG,		! Adr. of word containing log flag

;	0444		MAXLIM)		! Adr. of word containing image max error limit

;	0445		:NOVALUE =			! No value is returned

;	0446	

;	0447	!++

;	0448	! FUNCTIONAL DESCRIPTION:

;	0449	!

;	0450	!

;	0451	! FORMAL PARAMETERS:

;	0452	!

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

;	0454	!				to which the following parameters apply.

;	0455	!	[CONTIN.rw.r		Optional adr. of word specifying whether or not to

;	0456	!				continue after an error.  .TRUE. means continue

;	0457	!				after the error is detected.  .FALSE. causes

;	0458	!				an EXIT after the error.

;	0459	!	[COUNT.rw.r		Optional adr. of word specifying whether to count

;	0460	!				this error against the image's maximum

;	0461	!				 error limit.  .TRUE. means count the error;

;	0462	!				.FALSE. means do not count.

;	0463	!	[CONT_TYPE.rw.r		Optional adr. of word specifying the type of continuation

;	0464	!				to be performed after error detection.  

;	0465	!				.TRUE. passes control to an ERR= transfer label

;	0466	!				if supplied by the user;  .FALSE. causes

;	0467	!				a return to the routine that detected the

;	0468	!				error for default error recovery.

;	0469	!	[LOG.rw.r		Optional adr. of word specifying whether to produce

;	0470	!				an error message for this error.  .TRUE. produces

;	0471	!				a message (using signal mechanism);

;	0472	!				.FALSE. suppresses the message.

;	0473	!	[MAXLIM.rw.r]]]]]	Optional adr. of word containing positive

;	0474	!				integer used to set the image's maximum error limit.

;	0475	!				The default value is set to 15 at image initialization.

;	0476	!

;	0477	! IMPLICIT INPUTS:

;	0478	!

;	0479	!	COM$$ERR_TAB byte table indexed by error number

;	0480	!

;	0481	! IMPLICIT OUTPUTS:

;	0482	!

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

;	0484	!

;	0485	! ROUTINE VALUE:

;	0486	! COMPLETION CODES:

;	0487	!

;	0488	!	NONE

;	0489	!

;	0490	! SIDE EFFECTS:

;	0491	!

;	0492	!	OWN storage COM$$ERR_TAB is changed as specified.



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:11:48	DBB3:[RTL.SRC]CERRSE.B32;7					Page 3-1

;

;	0493	!	SIGNAL_STOPs FOR$_INVARGFOR (48='INVALID ARGUMENT TO FORTRAN I/O LIBRARY')

;	0494	!	If error number is floating underflow (74),

;	0495	!	either enable or diable floating underflow for calling procedure

;	0496	!	activation depending on final setting of LOG status bit for

;	0497	!	error 74.  This is not quite the same as the PDP-11 where

;	0498	!	the enable or disable affects all procedure activations not just caller.

;	0499	!--

;	0500	

;	0501	    BEGIN

;	0502	    MAP

;	0503		FORT_ERR_NO:	REF VECTOR[1,WORD],

;	0504		CONTIN:		REF VECTOR[1,WORD],

;	0505		COUNT:		REF VECTOR[1,WORD],

;	0506		CONT_TYPE:		REF VECTOR[1,WORD],

;	0507		LOG:		REF VECTOR[1,WORD],

;	0508		MAXLIM:		REF VECTOR[1,WORD];

;	0509	    LOCAL

;	0510		N;			! Temporary FORTRAN error number for this error

;	0511	

;	0512	    !+

;	0513	    ! If no FORT_ERR_NO, SIGNAL_STOP FOR$_INVARGFOR (48='INVALID ARGUMENT TO FORTRAN I/O LIBRARY')

;	0514	    !-

;	0515	

;	0516	    IF NULLPARAMETER (1) THEN FOR$$SIG_NO_LUB (FOR$K_INVARGFOR);

;	0517	    N = .FORT_ERR_NO[0];

;	0518	

;	0519	    !+

;	0520	    ! Check range of FORTRAN error number and whether a defined error number

;	0521	    !-

;	0522	

;	0523	    IF .N GTRU FOR$K_MAX_ERR THEN FOR$$SIG_NO_LUB (FOR$K_INVARGFOR);

;	0524	    IF .COM$$ERR_TAB[.N, B_EC_ANY] EQL 0 THEN FOR$$SIG_NO_LUB (FOR$K_INVARGFOR);

;	0525	

;	0526	    !+

;	0527	    ! Continuation arg - If TRUE, check if allowed to continue

;	0528	    ! by making sure either continue or ERR= is allowed.

;	0529	    !-

;	0530	

;	0531	    IF NOT NULLPARAMETER (2)

;	0532	    THEN

;	0533		BEGIN

;	0534		COM$$ERR_TAB[.N, V_EC_CONTINUE] = 0;

;	0535		IF .CONTIN[0]

;	0536		THEN

;	0537		    BEGIN

;	0538		    IF NOT .COM$$ERR_TAB[.N, V_EC_CONT_ALLOW] AND NOT .COM$$ERR_TAB[.N, V_EC_EREQ_ALLOW]

;	0539		    THEN

;	0540			FOR$$SIG_NO_LUB (FOR$K_INVARGFOR);

;	0541		    COM$$ERR_TAB[.N, V_EC_CONTINUE] = 1;

;	0542		    END

;	0543		END;

;	0544	

;	0545	    !+

;	0546	    ! Count control - if present, copy user arg

;	0547	    !-



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:11:48	DBB3:[RTL.SRC]CERRSE.B32;7					Page 3-2

;

;	0548	

;	0549	    IF NOT NULLPARAMETER (3) THEN COM$$ERR_TAB[.N, V_EC_COUNT] = .COUNT[0];

;	0550	

;	0551	    !+

;	0552	    ! Continuation type - If 1 (ERR=), check if allowed.

;	0553	    ! If 0 (continue), check if allowed.

;	0554	    !-

;	0555	

;	0556	    IF NOT NULLPARAMETER (4)

;	0557	    THEN

;	0558		BEGIN

;	0559		IF .CONT_TYPE[0]

;	0560		THEN		! User wants ERR=

;	0561		    BEGIN

;	0562		    IF NOT .COM$$ERR_TAB[.N, V_EC_EREQ_ALLOW] THEN FOR$$SIG_NO_LUB (FOR$K_INVARGFOR);

;	0563		    COM$$ERR_TAB[.N, V_EC_CONT_TYPE] = 1;

;	0564		    END

;	0565		ELSE		! User wants to continue in run-time library

;	0566		    BEGIN

;	0567		    IF NOT .COM$$ERR_TAB[.N, V_EC_CONT_ALLOW] THEN FOR$$SIG_NO_LUB (FOR$K_INVARGFOR);

;	0568		    COM$$ERR_TAB[.N, V_EC_CONT_TYPE] = 0;

;	0569		    END

;	0570		END;

;	0571	

;	0572	    !+

;	0573	    ! Log control - copy user arg

;	0574	    !-

;	0575	

;	0576	    IF NOT NULLPARAMETER (5) THEN COM$$ERR_TAB[.N, V_EC_LOG] = .LOG[0];

;	0577	

;	0578	    !+

;	0579	    ! Maximum error limit - copy user arg if present

;	0580	    !-

;	0581	

;	0582	    IF NOT NULLPARAMETER (6) THEN COM$$ERRORCOUNT = .MAXLIM[0];

;	0583	

;	0584	    !+

;	0585	    ! If this error is floating underflow (74)

;	0586	    ! Set or clear floating underflow for calling procedure activation,

;	0587	    ! depending on whether floating underflow is to be logged or not.

;	0588	    ! Note: this is not quite the same as the PDP-11 where the enable

;	0589	    ! takes effect for all procedure activations.

;	0590	    !-

;	0591	

;	0592	    IF .N EQL FOR$K_FLOUND

;	0593	    THEN

;	0594		BEGIN

;	0595		BUILTIN FP;		! Stack frame pointer

;	0596		MAP FP: REF BLOCK[, BYTE];	! Use MDL definitions

;	0597		BLOCK[.FP[SF$L_SAVE_FP], SF$V_FU] = .COM$$ERR_TAB[FOR$K_FLOUND, V_EC_LOG]

;	0598		END;

;	0599	

;	0600	    !+

;	0601	    ! Return

;	0602	    !-



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:11:48	DBB3:[RTL.SRC]CERRSE.B32;7					Page 3-3

;

;	0603	

;	0604	    RETURN

;	0605	    END;			! End of ERRSET





							    .TITLE  COM$ERRSET

							    .IDENT  \1-06\



							    .EXTRN  COM$$ERR_TAB, COM$$ERRORCOUNT, FOR$$SIG_NO_LUB



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



					 001C 00000 	    .ENTRY  ERRSET, Save R2,R3,R4				      ; 0438

		         54 00000000G  00  9E 00002 	    MOVAB   FOR$$SIG_NO_LUB, R4					      ;

		         01 	       6C  91 00009 	    CMPB    (AP), #1						      ; 0516

				       05  1F 0000C 	    BLSSU   1$							      ;

				  04   AC  D5 0000E 	    TSTL    4(AP)						      ;

				       05  12 00011 	    BNEQ    2$							      ;

				       30  DD 00013 1$:     PUSHL   #48							      ;

		         64 	       01  FB 00015 	    CALLS   #1, FOR$$SIG_NO_LUB					      ;

		         53 	  04   BC  3C 00018 2$:     MOVZWL  @FORT_ERR_NO, N					      ; 0517

	      0000005D   8F	       53  D1 0001C 	    CMPL    N, #93						      ; 0523

				       05  1B 00023 	    BLEQU   3$							      ;

				       30  DD 00025 	    PUSHL   #48							      ;

		         64 	       01  FB 00027 	    CALLS   #1, FOR$$SIG_NO_LUB					      ;

		         52 00000000G0043  9E 0002A 3$:     MOVAB   COM$$ERR_TAB[N], R2					      ; 0524

				       62  95 00032 	    TSTB    (R2)						      ;

				       05  12 00034 	    BNEQ    4$							      ;

				       30  DD 00036 	    PUSHL   #48							      ;

		         64 	       01  FB 00038 	    CALLS   #1, FOR$$SIG_NO_LUB					      ;

		         02 	       6C  91 0003B 4$:     CMPB    (AP), #2						      ; 0531

				       1C  1F 0003E 	    BLSSU   6$							      ;

				  08   AC  D5 00040 	    TSTL    8(AP)						      ;

				       17  13 00043 	    BEQL    6$							      ;

		         62 	       01  8A 00045 	    BICB2   #1, (R2)						      ; 0534

		         10 	  08   BC  E9 00048 	    BLBC    @CONTIN, 6$						      ; 0535

	   09 	         62 	       05  E0 0004C 	    BBS     #5, (R2), 5$					      ; 0538

	   05 	         62 	       06  E0 00050 	    BBS     #6, (R2), 5$					      ;

				       30  DD 00054 	    PUSHL   #48							      ; 0540

		         64 	       01  FB 00056 	    CALLS   #1, FOR$$SIG_NO_LUB					      ;

		         62 	       01  88 00059 5$:     BISB2   #1, (R2)						      ; 0541

		         03 	       6C  91 0005C 6$:     CMPB    (AP), #3						      ; 0549

				       0B  1F 0005F 	    BLSSU   7$							      ;

				  0C   AC  D5 00061 	    TSTL    12(AP)						      ;

				       06  13 00064 	    BEQL    7$							      ;

	   01 	         01 	  0C   BC  F0 00066 	    INSV    @COUNT, #1, #1, (R2)				      ;

				       62     0006B									      ;

		         04 	       6C  91 0006C 7$:     CMPB    (AP), #4						      ; 0556

				       23  1F 0006F 	    BLSSU   11$							      ;

				  10   AC  D5 00071 	    TSTL    16(AP)						      ;

				       1E  13 00074 	    BEQL    11$							      ;

		         0E 	  10   BC  E9 00076 	    BLBC    @CONT_TYPE, 9$					      ; 0559

	   05 	         62 	       06  E0 0007A 	    BBS     #6, (R2), 8$					      ; 0562

				       30  DD 0007E 	    PUSHL   #48							      ;

		         64 	       01  FB 00080 	    CALLS   #1, FOR$$SIG_NO_LUB					      ;



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:11:48	DBB3:[RTL.SRC]CERRSE.B32;7					Page 3-4

;

		         62 	       04  88 00083 8$:     BISB2   #4, (R2)						      ; 0563

				       0C  11 00086 	    BRB     11$							      ; 0558

	   05 	         62 	       05  E0 00088 9$:     BBS     #5, (R2), 10$					      ; 0567

				       30  DD 0008C 	    PUSHL   #48							      ;

		         64 	       01  FB 0008E 	    CALLS   #1, FOR$$SIG_NO_LUB					      ;

		         62 	       04  8A 00091 10$:    BICB2   #4, (R2)						      ; 0568

		         05 	       6C  91 00094 11$:    CMPB    (AP), #5						      ; 0576

				       0B  1F 00097 	    BLSSU   12$							      ;

				  14   AC  D5 00099 	    TSTL    20(AP)						      ;

				       06  13 0009C 	    BEQL    12$							      ;

	   01 	         03 	  14   BC  F0 0009E 	    INSV    @LOG, #3, #1, (R2)					      ;

				       62     000A3									      ;

		         06 	       6C  91 000A4 12$:    CMPB    (AP), #6						      ; 0582

				       0D  1F 000A7 	    BLSSU   13$							      ;

				  18   AC  D5 000A9 	    TSTL    24(AP)						      ;

				       08  13 000AC 	    BEQL    13$							      ;

	      00000000G  00	  18   BC  3C 000AE 	    MOVZWL  @MAXLIM, COM$$ERRORCOUNT				      ;

	      0000004A   8F	       53  D1 000B6 13$:    CMPL    N, #74						      ; 0592

				       13  12 000BD 	    BNEQ    14$							      ;

		         50 	  0C   AE  D0 000BF 	    MOVL    12(FP), R0						      ; 0597

00000000G  00	         01 	       03  EF 000C3 	    EXTZV   #3, #1, COM$$ERR_TAB+74, R1				      ;

				       51     000CB									      ;

	   01 	         06 	       51  F0 000CC 	    INSV    R1, #6, #1, 16(R0)					      ;

				  10   A0     000D0									      ;

					   04 000D2 14$:    RET     							      ; 0438



; Routine Size:  211 bytes





;	0606	

;	0607	

;	0608	END

;	0609	ELUDOM













;				       PSECT SUMMARY

;

;	Name		 Bytes			       Attributes

;

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









;				LIBRARY STATISTICS

;

;					     -------- Symbols --------    Blocks

;	File				     Total    Loaded   Percent      Read

;

;  DBA4:[SYSLIB]STARLET.L32;1		      2688         7         0       110





; Bliss-32 10.1-416	Monday 21-AUG-1978 19:11:48	DBB3:[RTL.SRC]CERRSE.B32;7					Page 3-5

;









; Size:		211 code + 0 data bytes

; Run Time:	00:08.3

; Elapsed Time:	00:21.7

; Memory Used:	204 pages

; Compilation Complete

