Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-03 - decus/20-0078/libsim/read.mac
There are 5 other files named read.mac in the archive. Click here to see a list.
00100	COMMENT ! SIMULA specification;
00200	OPTIONS(/EXTERNAL:CODE,NOCHECK,read);
00300	PROCEDURE read;
00400	
00500	!;! MACRO-10 code !
00600	
00700		TITLE	read
00800		SUBTTL	SIMULA utility, Lars Enderin Nov 1975
00900	
01000	;!*** Copyright 1975 by the Swedish Defence Research Institute. ***
01100	;!*** Copying is allowed.					***
01200	
01300		SEARCH	simrpa,simmcr,simmac
01400		sall
01500		macinit
01600		ENTRY	read
01700	
01800	Comment/
01900	Reads items into successive parameters from the current Infile or Directfile.
02000	The current file is initially Sysin, but may be changed by giving another
02100	Infile or Directfile reference as parameter. The other parameters may be of type
02200	INTEGER, REAL, LONG REAL or CHARACTER. Inint, Inreal or Inchar is used depending
02300	on the parameter type. Since the procedure is specified NOCHECK, all parameters
02400	are passed by name. Arrays of suitable types are allowed as parameters.
02500	/
02600		DEFINE	NOTHUNK(X)<JUMPGE X,FALSE>
02700		Xtyp==XWAC10
02800		Xkind==XWAC11
02900		XN==Xkind+1
03000	
03100		OPDEF	readitem	[PUSHJ XPDP,readitem]
03200	
03300	
03400	read:
03500		PROC
03600		LOWADR
03700		L	XWAC2,YSYSIN(XLOW)	;! Default input file
03800		HRLI	XWAC1,2			;! Dynamic addr of ZFL
03900		HRRI	XWAC1,(XCB)
04000	
04100		WHILE	;! More parameters
04200			CAML	XWAC1,[^D32+1,,0]
04300			GOTO	FALSE
04400			HLRZ	X1,XWAC1
04500			ADDI	X1,(XWAC1)	;! abs addr of ZFL
04600			SKIPN	(X1)		;! No more if ZFL=0
04700			GOTO	FALSE
04800		DO
04900			WLF	,ZFLAKD(X1)	;! 1st ZFL word to X0
05000			LF	Xkind,ZFLAKD	;! Kind
05100			LF	Xtyp,ZFLATP	;! Type
05200			IF	;! type is REF
05300				CAIE	Xtyp,QREF
05400				GOTO	FALSE
05500			THEN	;! It has to be NONE, Infile or Directfile
05600				L	XWAC2,XWAC1
05700				EXEC	PHFV		;! Get file ref
05800				XWD	1,[1B0]		;! preserves ZFL address
05900				IF	;! NONE
06000					CAIE	XWAC2,NONE
06100					GOTO	FALSE	;! [145]
06200				THEN	;! Assume Sysin
06300					LOWADR
06400					L	XWAC2,YSYSIN(XLOW)
06500				ELSE	;! Check qualification
06600					HLRZ	X1,XWAC1
06700					ADDI	X1,(XWAC1)
06800					LF	,ZFLZQU(X1)
06900					IF	;! Not Infile or Directfile
07000						CAIE	IOIN
07100						CAIN	IODF
07200						GOTO	FALSE
07300					THEN	;! Error!
07400						RTSERR	111	;! Wrong qualification
07500				FI	FI
07600			ELSE	;! Expressions are not allowed
07700				IFONA	ZFLVTD
07800				RTSERR	100	;! Illegal assignment implied
07900				IF
08000					NOTHUNK
08100				THEN	;! Compute parameter address directly
08200					LF	XWAC3,ZFLOFS(X1)
08300					ADD	XWAC3,OFFSET(ZFLZBI)(X1)
08400					CAIN	Xkind,QARRAY
08500					L	XWAC3,(XWAC3)	;! Array address
08600				ELSE	;! Evaluate thunk for the address
08700					L	XWAC3,XWAC1
08800					LI	X1,PHFA		;! For simple items
08900					CAIN	Xkind,QARRAY
09000					LI	X1,PHFM		;! For arrays
09100					EXEC	0(X1)
09200					XWD	2,[1B0+1B1]
09300					HLRZ	XWAC4,XWAC3	;! Abs address from
09400					ADDI	XWAC3,(XWAC4)	;!  dynamic address
09500					HLRZ	X1,XWAC1	;! Reload X1, Xtyp
09600					ADDI	X1,(XWAC1)
09700					LF	Xtyp,ZFLATP(X1)
09800				FI
09900				L	XWAC4,XWAC2	;! Load top ac
10000				LI	XTAC,XWAC4	;! Specify top ac
10100				IF	;! Kind is simple
10200					CAIE	Xkind,QSIMPLE
10300					GOTO	FALSE
10400				THEN	;! input one item
10500					readitem
10600				ELSE	;! Must be array
10700					CAIE	Xkind,QARRAY
10800					RTSERR	113
10900					LF	XN,ZARSUB(XWAC3)
11000					IMULI	XN,3
11100					LF	,ZARLEN(XWAC3)
11200					SUBI	3(XN)
11300					MOVN		;! Neg count
11400					ADDI	XWAC3,3(XN)
11500					HRLM	XWAC3	;! AOBJN word
11600					IF	;! TEXT or LONG REAL
11700						CAIE	Xtyp,QTEXT
11800						CAIN	Xtyp,QLREAL
11900						GOTO	TRUE
12000						GOTO	FALSE
12100					THEN	;! 2 words at a time
12200						LOOP
12300							readitem
12400						AS
12500							AOBJP	XWAC3,.+1
12600							AOBJN	XWAC3,TRUE
12700						SA
12800					ELSE	;! One word
12900						LOOP
13000							readitem
13100						AS
13200							AOBJN	XWAC3,TRUE
13300						SA
13400				FI	FI
13500			FI
13600			ADD	XWAC1,[2,,0]
13700		OD
13800		BRANCH	CSES
13900		EPROC
     
14000	readitem:PROC
14100		L	XWAC4,XWAC2	;! Load top ac
14200		LI	XTAC,XWAC4	;! Specify top ac
14300		IF	;! INTEGER
14400			CAIE	Xtyp,QINTEGER
14500			GOTO	FALSE
14600		THEN	;! use Inint
14700			EXEC	IOII
14800		ELSE
14900		IF	;! REAL or LONG REAL
15000			CAILE	Xtyp,QLREAL
15100			GOTO	FALSE
15200		THEN	;! use Inreal
15300			EXEC	IOIR
15400			CAIN	Xtyp,QLREAL
15500			ST	1+XWAC4,1(XWAC3)	;! Store second word
15600		ELSE
15700		IF	;! CHARACTER
15800			CAIE	Xtyp,QCHARACTER
15900			GOTO	FALSE
16000		THEN	;! use Inchar
16100			EXEC	IOIC
16200		ELSE	;! Wrong type
16300			RTSERR	107
16400		FI	FI	FI
16500		ST	XWAC4,(XWAC3)	;! Store (first word of) value
16600		RETURN
16700		EPROC
16800		END;