

; Bliss-32 10.1-416	Monday 21-AUG-1978 19:20:10	DBB3:[RTL.SRC]FIOEND.B32;7					Page 1

;

;00100  0001	MODULE FOR$IO_END (	! FORTRAN End I/O statement

;00200  0002		IDENT = '0-18'	! File: FIOEND.B32

;00300  0003			) =

;00400  0004	BEGIN

;00500  0005	

;00600  0006	!

;00700  0007	! COPYRIGHT (C) 1977

;00800  0008	! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASSACHUSETTS 01754

;00900  0009	!

;01000  0010	! THIS SOFTWARE IS FURNISHED  UNDER A LICENSE FOR USE ONLY ON A SINGLE

;01100  0011	! COMPUTER  SYSTEM AND  MAY BE  COPIED ONLY WITH  THE INCLUSION OF THE

;01200  0012	! ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE, OR ANY OTHER COPIES THEREOF,

;01300  0013	! MAY NOT BE PROVIDED OR  OTHERWISE MADE AVAILABLE TO ANY OTHER PERSON

;01400  0014	! EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO AGREES TO THESE LICENSE

;01500  0015	! TERMS.  TITLE TO AND  OWNERSHIP OF THE  SOFTWARE  SHALL AT ALL TIMES

;01600  0016	! REMAIN IN DEC.

;01700  0017	!

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

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

;02000  0020	! CORPORATION.

;02100  0021	!

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

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

;02400  0024	

;02500  0025	!++

;02600  0026	! FACILITY: FORTRAN Support Library - user callable

;02700  0027	!

;02800  0028	! ABSTRACT:

;02900  0029	!

;03000  0030	!	This module terminates a FORTRAN I/O statement, writes

;03100  0031	!	last record if output, and pops up the I/O system to

;03200  0032	!	a previously active I/O statement if any.

;03300  0033	!

;03400  0034	! ENVIRONMENT: User access mode; mixture of AST level or not

;03500  0035	!

;03600  0036	! AUTHOR: Thomas N. Hastings, CREATION DATE: 03-Mar-77

;03700  0037	!

;03800  0038	! MODIFIED BY:

;03900  0039	!

;04000  0040	!	Thomas N. Hastings, 05-Mar-77 : VERSION 01

;04100  0041	! 01	-  original

;04200  0042	! 0-12	- Use FOR$K_abcmno12yz as E12TERNAL LITERALs.  TNH 27-Oct-77

;04300  0043	! 0-13	- Use FERR and call FOR$$FREE_VM.  TNH 16-Dec-77

;04400  0044	! 0-14	- If ISB$B_ERR_NO is non-zero, SIGNAL its contents.  JMT 14-Jan-78

;04500  0045	! 0-15	- Global register CCB.  JMT 8-Apr-78

;04600  0046	! 0-16	- Change REQUIRE files for VAX system build.  DGP 28-Apr-78

;04610  0047	! 0-17	- Use JSB linkages.  TNH 21-May-78

;04620  0048	! 0-18	- PIC dispatch tables.  TNH 10-June-78

;04700  0049	!--



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:20:10	DBB3:[RTL.SRC]FIOEND.B32;7					Page 2

;

;00100  0050	!

;00200  0051	! LINKAGES:

;00300  0052	!

;00500  0053	REQUIRE 'RTLIN:FLNK';		! Define all linkages

; %PRINT:	File: FLNK.B32; Version 1, edit 12, TNH 2-Aug-78

;00600  0275	

;00700  0276	!

;00800  0277	! TABLE OF CONTENTS:

;00900  0278	!

;01000  0279	

;01100  0280	FORWARD ROUTINE

;01200  0281		FOR$IO_END: NOVALUE;	! End I/O statement

;01300  0282	

;01400  0283	!

;01500  0284	! INCLUDE FILES:

;01600  0285	!

;01700  0286		REQUIRE 'RTLML:FERR';		! FORTRAN error number definitions

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

;01800  0404		REQUIRE 'RTLML:FISB';		! I/O statement block (ISB)

; %PRINT:	File: FISB.MDL which produces FISB.B32! Version 1, EDIT 16, DGP 02-Jun-78

;01900  0613		REQUIRE 'RTLML:FLUB';		! needed only for LUB length

; %PRINT:	File: FLUB.MDL which produces FLUB.B32! Version 0, edit 30, TNH, 17-June-78

;02000  0781		REQUIRE 'RTLIN:FMAC';		! FORTRAN macros

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

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

;02100  0961		REQUIRE 'RTLML:FPAR';		! FORTRAN inter-module parameters

; %PRINT:	File: FPAR.MDL! version 0, edit 11, TNH, 30-May-78

;02200  1063		REQUIRE 'RTLIN:ODBG';		! debugging macros

; %PRINT:	Filename: NODBG.B32; Version 0, edit 20, JMT, 17-Jan-78

;02300  1139	

;02400  1140	!

;02500  1141	! MACROS:

;02600  1142	!

;02700  1143	!	NONE

;02800  1144	

;02900  1145	!

;03000  1146	! EQUATED SYMBOLS:

;03100  1147	!

;03200  1148	!	NONE

;03300  1149	

;03400  1150	!

;03500  1151	! PSECT DECLARATIONS:

;03600  1152	!

;03700  1153	

;03800  1154		DECLARE_PSECTS (FOR);	! declare PSECTs for FOR$ facility

;03900  1155	

;04000  1156	!

;04100  1157	! OWN STORAGE:

;04200  1158	!

;04300  1159	!	NONE

;04400  1160	

;04500  1161	!

;04600  1162	! EXTERNAL REFERENCES:

;04700  1163	!

;04800  1164	



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:20:10	DBB3:[RTL.SRC]FIOEND.B32;7					Page 2-1

;

;04900  1165	EXTERNAL

;05000  1166		OTS$$A_CUR_LUB: ADDRESSING_MODE (GENERAL), ! Pointer to current LUB/ISB/RAB

;05100  1167		FOR$$AA_UDF_PR9: ADR_VECTOR;	! PIC array of user data

;05200  1168						! formatter (UDF) level of abstraction.

;05300  1169	

;05400  1170	EXTERNAL ROUTINE

;05500  1171		FOR$$ERR_ENDHND,		! error condition handler for END= and ERR=

;05600  1172		FOR$$FREE_VM: NOVALUE, 		! Return dynamically allocated virtual memory

;05700  1173						! if this statement has an object-time format

;05800  1174		FOR$$CB_POP: JSB_CB_POP NOVALUE,	! Pop entire I/O system back to previous LUB/ISB/RAB

;05900  1175		FOR$$SIGNAL: NOVALUE;		! Signal an error with a small error number



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:20:10	DBB3:[RTL.SRC]FIOEND.B32;7					Page 3

;

;00100  1176	GLOBAL ROUTINE FOR$IO_END :NOVALUE =	!

;00200  1177	

;00300  1178	!++

;00400  1179	! FUNCTIONAL DESCRIPTION:

;00500  1180	!

;00600  1181	!

;00610  1182	! CALLING SEQUENCE:

;00620  1183	!

;00630  1184	!	CALL FOR$IO_END ()

;00640  1185	!

;00700  1186	! FORMAL PARAMETERS:

;00800  1187	!

;00900  1188	!	NONE

;01000  1189	!

;01100  1190	! IMPLICIT INPUTS:

;01200  1191	!

;01300  1192	!	OTS$$A_CUR_LUB		Adr. of current logical unit

;01400  1193	!				block (LUB). Used to setup ISB

;01500  1194	!				to get current I/O statement type

;01600  1195	!				code.

;01700  1196	!	ISB$B_STTM_TYPE		I/O statement type code - index to

;01800  1197	!				dispatch table entry.

;01900  1198	!	FOR$A_UDF_PR1		Array of user data formatters

;02000  1199	!				(UDF level of abstraction).

;02100  1200	!	ISB$W_FMT_LEN		No. of char. allocated to object-time format or 0

;02200  1201	!	ISB$A_FMT_BEG		Adr. of dynamically allocated object-time

;02300  1202	!	ISB$B_ERR_NO		Last continuable error to occur in the state-

;02400  1203	!				ment or 0.  SIGNAL if non-zero!

;02500  1204	!				format array or 0 if none.

;02600  1205	!

;02700  1206	! IMPLICIT OUTPUTS:

;02800  1207	!

;02900  1208	!	OTS$$A_CUR_LUB		Adr. of pushed down LUB/ISB/RAB or 0

;03000  1209	!				if no unit pushed down (usual)

;03100  1210	!	ISB$W_FMT_LEN		Set to 0

;03200  1211	!	ISB$A_FMT_BEG		Set to 0

;03300  1212	!

;03400  1213	! ROUTINE VALUE:

;03500  1214	!

;03600  1215	!	NONE

;03700  1216	!

;03800  1217	! SIDE EFFECTS:

;03900  1218	!

;04000  1219	!	If an object-time format has been allocated (ISB$A_FMT_BEG NEQ 0)

;04100  1220	!	ISB$W_FMT_LEN characters are deallocated.

;04200  1221	!	If an error occurs, it is SIGNALed unless an ERR=

;04300  1222	!	transfer parameter was specified when the I/O statement

;04400  1223	!	initialization call was made (see module FOR$IO_BEG,

;04500  1224	!	entry points FOR${READ,WRITE}_{SF,SO,SU,DF,DO,DU,SL} or

;04600  1225	!	FOR${DECODE,ENCODE}_{MF,MO}), in which case control is

;04700  1226	!	transferred to the specified address (after stack

;04800  1227	!	unwind).

;04900  1228	!

;05000  1229	!--

;05100  1230	



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:20:10	DBB3:[RTL.SRC]FIOEND.B32;7					Page 3-1

;

;05200  1231	    BEGIN

;05300  1232	

;05400  1233	    GLOBAL REGISTER

;05500  1234		CCB = K_CCB_REG: REF BLOCK[, BYTE];

;05600  1235	

;05700  1236	    LOCAL				! Declare locals for each item to be passed to handler

;05800  1237						! Needed since can only pass address, not contents

;05900  1238		L_UNWIND_ACTION: VOLATILE,	! UNWIND action code.

;06000  1239		A_ERR_ADR: VOLATILE,		! ERR= user address

;06100  1240		A_END_ADR: VOLATILE,		! END= user address

;06200  1241		L_INCR_DEPTH: VOLATILE;		! additional frames between establisher and user (0)

;06300  1242	    ENABLE				! Establish error conditon handler

;06400  1243		FOR$$ERR_ENDHND (L_UNWIND_ACTION, A_ERR_ADR, A_END_ADR, L_INCR_DEPTH);

;06500  1244						! Pass UNWIND action code.

;06600  1245						! Pass ERR= and END= user addresses or 0

;06700  1246						! and the number of frames between the activator and the user (0)

;06800  1247	

;06900  1248	    CCB = .OTS$$A_CUR_LUB;

;07000  1249	

;07100  1250	    !+

;07200  1251	    ! Print input formals and implicit inputs, if debugging

;07300  1252	    !-

;07400  1253	

;07500  1254	    INPUT_FORMALS ('FOR$IO_END');

;07600  1255	    IMPLICIT_INPUTS ('FOR$IO_END', '.OTS$$A_CUR_LUB', .OTS$$A_CUR_LUB);

;07700  1256	

;07800  1257	    !+

;07900  1258	    ! Setup LOCAL storage to be passed to error handler in case of a signal

;08000  1259	    ! Indicate that UNWIND action is to pop current LUB/ISB/RAB if error

;08100  1260	    !-

;08200  1261	

;08300  1262	    L_UNWIND_ACTION = FOR$K_UNWINDPOP;

;08400  1263	    A_ERR_ADR = .CCB[ISB$A_ERR_EQUAL];

;08500  1264	    A_END_ADR = .CCB[ISB$A_END_EQUAL];

;08600  1265	    L_INCR_DEPTH = 0;

;08700  1266	

;08800  1267	    !+

;08900  1268	    ! Call appropriate UDF termination routine

;09000  1269	    ! Any errors will be signaled.

;09100  1270	    !-

;09200  1271	

;09300  1272	    JSB_UDF9 (FOR$$AA_UDF_PR9 + .FOR$$AA_UDF_PR9[.CCB[ISB$B_STTM_TYPE]]);

;09400  1273	

;09500  1274	    !+

;09600  1275	    ! If a continuable error occured on the I/O statement (ISB$B_ERR_NO

;09700  1276	    ! is non-zero) then SIGNAL the error.  The signalling is delayed until

;09800  1277	    ! statement end time so the record is positioned correctly.

;09900  1278	    !-

;10000  1279	

;10100  1280	    IF .CCB[ISB$B_ERR_NO] NEQU 0

;10200  1281	    THEN

;10300  1282		FOR$$SIGNAL (.CCB[ISB$B_ERR_NO]);

;10400  1283	

;10500  1284	    !+

;10600  1285	    ! If this statement has an object-time format array allocated,



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:20:10	DBB3:[RTL.SRC]FIOEND.B32;7					Page 3-2

;

;10700  1286	    ! return virtual memory (SIGNAL_STOP OTS$_FATINTERR if error).

;10800  1287	    !-

;10900  1288	

;11000  1289	    IF .CCB[ISB$W_FMT_LEN] NEQ 0

;11100  1290	    THEN

;11200  1291		BEGIN

;11300  1292		FOR$$FREE_VM (.CCB[ISB$W_FMT_LEN], .CCB[ISB$A_FMT_BEG]);

;11400  1293		CCB[ISB$W_FMT_LEN] = 0;

;11500  1294		CCB[ISB$A_FMT_BEG] = 0;

;11600  1295		END;

;11700  1296	

;11800  1297	    ! Pop entire I/O system back to previous LUB/ISB/RAB if there was one when this

;11900  1298	    ! I/O statement began (see FIOBEG) or indicate that I/O system is not.

;12000  1299	    ! currently processing any I/O statement (usual)

;12100  1300	    ! LUB for (old) current unit is saved for next I/O statement

;12200  1301	    !-

;12300  1302	

;12400  1303	    FOR$$CB_POP ();

;12500  1304	

;12600  1305	    !+

;12700  1306	    ! Print return value, output formals, and implicit outputs, if debugging

;12800  1307	    !-

;12900  1308	

;13000  1309	    FUNCTION_VALUE ('FOR$IO_END');

;13100  1310	    OUTPUT_FORMALS ('FOR$IO_END');

;13200  1311	    IMPLICIT_OUTPUT ('FOR$$IO_END');

;13300  1312	    RETURN;

;13400  1313	    END;		! End of routine





							    .TITLE  FOR$IO_END

							    .IDENT  \0-18\



							    .EXTRN  OTS$$A_CUR_LUB, FOR$$AA_UDF_PR9, FOR$$ERR_ENDHND

							    .EXTRN  FOR$$FREE_VM, FOR$$CB_POP, FOR$$SIGNAL



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



					 0800 00000 	    .ENTRY  FOR$IO_END, Save R11				      ; 1176

		         5E 	       0C  C2 00002 	    SUBL2   #12, SP						      ;

				       7E  D4 00005 	    CLRL    L_INCR_DEPTH					      ; 1231

				  04   AE  D4 00007 	    CLRL    A_END_ADR						      ;

				  08   AE  D4 0000A 	    CLRL    A_ERR_ADR						      ;

				  0C   AE  D4 0000D 	    CLRL    L_UNWIND_ACTION					      ;

		         6D 0000004F   EF  DE 00010 	    MOVAL   3$, (FP)						      ;

		         5B 00000000G  00  D0 00017 	    MOVL    OTS$$A_CUR_LUB, CCB					      ; 1248

				  0C   AE  D4 0001E 	    CLRL    L_UNWIND_ACTION					      ; 1262

		    08   AE	  AC   AB  D0 00021 	    MOVL    -84(CCB), A_ERR_ADR					      ; 1263

		    04   AE	  B0   AB  D0 00026 	    MOVL    -80(CCB), A_END_ADR					      ; 1264

				       6E  D4 0002B 	    CLRL    L_INCR_DEPTH					      ; 1265

		         50 	  A5   AB  9A 0002D 	    MOVZBL  -91(CCB), R0					      ; 1272

		         50 	0000GCF40  32 00031 	    CVTWL   FOR$$AA_UDF_PR9[R0], R0				      ;

				0000GCF40  16 00037 	    JSB     FOR$$AA_UDF_PR9[R0]					      ;

				  A4   AB  95 0003C 	    TSTB    -92(CCB)						      ; 1280

				       09  13 0003F 	    BEQL    1$							      ;



; Bliss-32 10.1-416	Monday 21-AUG-1978 19:20:10	DBB3:[RTL.SRC]FIOEND.B32;7					Page 3-3

;

		         7E 	  A4   AB  9A 00041 	    MOVZBL  -92(CCB), -(SP)					      ; 1282

		  0000G  CF	       01  FB 00045 	    CALLS   #1, FOR$$SIGNAL					      ;

				  A6   AB  B5 0004A 1$:     TSTW    -90(CCB)						      ; 1289

				       12  13 0004D 	    BEQL    2$							      ;

				  B4   AB  DD 0004F 	    PUSHL   -76(CCB)						      ; 1292

		         7E 	  A6   AB  3C 00052 	    MOVZWL  -90(CCB), -(SP)					      ;

		  0000G  CF	       02  FB 00056 	    CALLS   #2, FOR$$FREE_VM					      ;

				  A6   AB  B4 0005B 	    CLRW    -90(CCB)						      ; 1293

				  B4   AB  D4 0005E 	    CLRL    -76(CCB)						      ; 1294

				     0000G 30 00061 2$:     BSBW    FOR$$CB_POP						      ; 1303

					   04 00064 	    RET     							      ; 1176

					 0000 00065 3$:     .WORD   Save nothing					      ; 1231

		         50 	  08   AC  D0 00067 	    MOVL    8(AP), R0						      ;

		         50 	  04   A0  D0 0006B 	    MOVL    4(R0), R0						      ;

				  F0   A0  9F 0006F 	    PUSHAB  L_INCR_DEPTH					      ;

				  F4   A0  9F 00072 	    PUSHAB  A_END_ADR						      ;

				  F8   A0  9F 00075 	    PUSHAB  A_ERR_ADR						      ;

				  FC   A0  9F 00078 	    PUSHAB  L_UNWIND_ACTION					      ;

				       04  DD 0007B 	    PUSHL   #4							      ;

				       5E  DD 0007D 	    PUSHL   SP							      ;

		         7E 	  04   AC  7D 0007F 	    MOVQ    4(AP), -(SP)					      ;

		  0000G  CF	       03  FB 00083 	    CALLS   #3, FOR$$ERR_ENDHND					      ;

					   04 00088 	    RET     							      ;



; Routine Size:  137 bytes





;13500  1314	

;13600  1315	END			!End of module FOR$IO_END

;13700  1316	ELUDOM













;				       PSECT SUMMARY

;

;	Name		 Bytes			       Attributes

;

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











; Size:		137 code + 0 data bytes

; Run Time:	00:08.1

; Elapsed Time:	00:19.1

; Memory Used:	66 pages

; Compilation Complete

