Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-05 - 43,50337/23/input.mac
There are 2 other files named input.mac in the archive. Click here to see a list.
COMMENT * SIMULA specification;
OPTIONS(/E:CODE,NOCHECK,input);
INTEGER PROCEDURE input;!(fileref,[[,item]...]);
COMMENT Inputs successive items from a file which is IN Infile
or Directfile. Image is not used - input is directly from the buffers;

!*;! MACRO-10 code !*;!

	TITLE	input
	ENTRY	input
	search	simmac,simmcr,simrpa
	sall
	macinit
	SUBTTL	SIMULA utility, Lars Enderin Oct 1975

	count==ZBI%S
	fileref==ZBI%S+1
	nextparam==fileref+1
	firstpar==fileref+2

	DEFINE ops(A)<
	IRP A,<
	OPDEF A [PUSHJ XPDP,A]
	>>

	ops	<pointers,inputword,inputtext,inputref,inputarray,newbuffer>
	ops	<inputmove>

	XSP==	13
	XBH==	7
	XFIL==	XWAC3
	XBP==	XWAC4
	XLI==	XL
	XPT==	14	;!??

	cnt==OFFSET(ZBHCNT)
	bup==OFFSET(ZBHBUP)
	maxoffset==^d31

	DEFINE inputerr(n,t)<
	EXEC	.inputerr
	n+"0",,[ASCIZ/t/]
	>

	DEFINE	normalize(xp)<
	IF	TLNE	xp,400000
		GOTO	FALSE
	THEN	HRLI	xp,440700
		ADDI	xp,1
	FI
>
	OPDEF	COMPBLOCK	[PUSHJ	XPDP,IOCB]
	OPDEF	COMPSTART	[PUSHJ	XPDP,IOCS]
	OPDEF	READBLOCK	[PUSHJ	XPDP,IORB]
	OPDEF	ERRFILE		[PUSHJ	XPDP,IOERF]
	SUBTTL	input

input:	PROC
	;! Compute file ref and check it
	IF	;! No thunk
		SKIPL	X1,fileref(XCB)
		GOTO	FALSE
	THEN	;! Easy access to value
		HRRZ	X2,fileref+1(XCB)
		ADDI	X2,(X1)
		L	XWAC1,(X2)	;! file reference
	ELSE	;! Use RTS routine
		LI	XWAC1,(XCB)
		HRLI	XWAC1,fileref
		EXEC	PHFV
		XWD	0,0
	FI
	ST	XWAC1,fileref(XCB)	;! save the computed value for later
	LF	X2,ZBIZPR(XWAC1)
	LOOP	;! Check qualif
		CAIE	X2,IOIN
		CAIN	X2,IODF
		GOTO	L1	;! Ok!
		LF	X2,ZCPZCP(X2)
	AS	;! long as there is a prefix
		JUMPN	X2,TRUE
	SA
	inputerr	3,Wrong file type
	GOTO	inpend
L1():!	IFON	ZIFEND(XWAC1)
	GOTO	EOFERR
	IF	;! No more data
		IFOFF	ZFIEND(XWAC1)
		GOTO	FALSE
	THEN	;! Set ENDFILE, return 0
		SETON	ZIFEND(XWAC1)
		GOTO	inpend
	FI
	L	[Z	firstpar(XCB)]
	ST	nextparam(XCB)
	IF	;! Directfile
		CAIE	X2,IODF
		GOTO	FALSE
	THEN	;! Check for end of file condition before proceeding
		LFE	,ZDFLOC(XWAC1)
		JUMPLE	inpeof
		LF	X1,ZDFLIM(XWAC1)
		CAILE	(X1)
		GOTO	inpeof
		SETOFF	ZDFOUT(XWAC1)	;!Signal input (not output)
		IF	;! First input or output after Locate
			IFON	ZFIPGT(XWAC1)
			GOTO	FALSE
		THEN	;! Must input correct block, compute byte pointer
			pointers
			COMPBLOCK
			STACK	X1	;! Used by COMPSTART as parameter in stack
			LF	X1,ZDFBLK(XWAC1)
			CAIE	(X1)
			READBLOCK	;! If different block
			COMPSTART
			UNSTK	X1
			SETON	ZFIPGT(XWAC1)
		FI
	ELSE	;! Infile
		L	XFIL,XWAC1
		LF	XBH,ZFIIBH(XFIL)
		SUBI	XBH,1
		L	XBP,bup(XBH)
		WHILE	;! Not on a word boundary
			TLNN	XBP,300000
			GOTO	FALSE
		DO	ILDB	XBP
			SOS	cnt(XBH)
			SKIPE		;! Do not count null character
			AOS	count(XCB)
		OD
		ST	XBP,bup(XBH)
	FI
;! Handle one parameter here
;! -------------------------

L2():!	LD	XWAC1,@nextparam(XCB)
	JUMPE	XWAC1,inpend
	pointers
	IF	;! File is not open
		IFON	ZFIOPN(XFIL)
		GOTO	FALSE
	THEN	inputerr	4,File not open
		BRANCH	inpend
	FI
	LF	X1,ZFLAKD(,XWAC1)
	LF	X2,ZFLATP(,XWAC1)

	IF	;! Kind is simple
		CAIE	X1,QSIMPLE
		GOTO	FALSE
	THEN
L3():!		IF	;! No thunk
			JUMPGE	XWAC1,FALSE
		THEN	;! Get dyn address directly
			HRLI	XWAC1,(XWAC2)
			ADDI	XWAC2,(XWAC1)	;! Abs address
			CAIN	X2,QREF	;! We need the value of a REF
			L	XWAC1,(XWAC2)
		ELSE	;! via PHFA, PHFV or PHFT
			LI	X1,PHFA
			CAIN	X2,QTEXT
			LI	X1,PHFT
			CAIN	X2,QREF	;![130]

			LI	X1,PHFV
			LI	XWAC1,(XCB)
			HRL	XWAC1,nextparam(XCB)
			EXEC	0(X1)
			XWD	0,0
			L	@nextparam(XCB)
			LF	X1,ZFLAKD
			LF	X2,ZFLATP
			HLRZ	XWAC2,XWAC1
			ADDI	XWAC2,(XWAC1)	;! Abs address
			pointers	;! reconstructed
		FI
		IF	;! Simple value type
			CAIL	X2,QTEXT
			GOTO	FALSE
		THEN	;![130] Must not be an expression
			IF
				IFOFFA	ZFLVTD(XWAC1)
				GOTO	FALSE
			THEN	inputerr	2,Expression not allowed
			FI
			inputword
			ST	(XWAC2)
			IF	;![130] Long real
				CAIE	X2,QLREAL
				GOTO	FALSE
			THEN	;!One more word
				inputword
				ST	1(XWAC2)
			FI
		ELSE
		IF	;![130] Constant
			HRRZ	@nextparam(XCB)
			JUMPN	FALSE
		THEN	;! Constants have no block address
			inputerr	2,Constant not allowed
		ELSE
		IF	;! TEXT
			CAIE	X2,QTEXT
			GOTO	FALSE
		THEN	;! We have dynamic address of text var in XWAC1
			;! Save in ZFL
			ST	XWAC1,@nextparam(XCB)
			inputtext
			HLRZ	X1,@nextparam(XCB)
			ADD	X1,@nextparam(XCB)
			STD	XWAC1,(X1)
		ELSE
		IF	;! REF
			CAIE	X2,QREF
			GOTO	FALSE
		THEN	inputref
		ELSE	;! Wrong type
			inputerr	1,Wrong type
		FI	FI	FI	FI
	ELSE	;! Not of simple kind, may be array or parameterless procedure
		IF	;![130] It is a procedure
			CAIE	X1,QPROCEDURE
			GOTO	FALSE
		THEN	;! Error unless TEXT or REF
			CAIE	X2,QTEXT
			CAIN	X2,QREF
			GOTO	L3
			inputerr	2,Expression or procedure not allowed
		ELSE
		IF	;! Array
			CAIE	X1,QARRAY
			GOTO	FALSE
		THEN	LI	XWAC1,(XCB)
			HRL	XWAC1,nextparam(XCB)
			EXEC	PHFM
			XWD	0,0
			pointers	;! reconstructed
			inputarray
		ELSE
			inputerr	2,Wrong kind
	FI	FI	FI

	HRRZ	nextparam(XCB)
	ADDI	2
	HRRM	nextparam(XCB)
	CAIL	maxoffset
	GOTO	inpend
	GOTO	L2	;! Fetch next parameter

EOFERR:	inputerr	6,End of file
	GOTO	inpend

inpeof:	HRROS	count(XCB)	;![126] Signal incomplete input
	SETON	ZIFEND(XFIL)
;!	GOTO	inpend

inpend:	LOWADR
	HRRI	XPDP,YOBJRT-1(XLOW)
	HRLI	XPDP,-QPDLEN
	L	count(XCB)
	IF	;! We had some error
		JUMPGE	FALSE
	THEN	;! Return -rh as result
		HRRZ
		MOVN
	FI
	ST	count(XCB)
	BRANCH	CSEP
	EPROC	;! input
	SUBTTL	pointers

pointers:
	L	XFIL,fileref(XCB)
	LF	XBH,ZFIIBH(XFIL)
	SUBI	XBH,1
	L	XBP,bup(XBH)
	normalize(XBP)
	ST	XBP,bup(XBH)
	RETURN
	SUBTTL	inputword

inputword:PROC
	SKIPG	cnt(XBH)
	NEWBUFFER
	MOVNI	5	;! Account for one word taken out of buffer
	ADDM	cnt(XBH)
	LI	5
	ADDM	count(XCB)
	L	(XBP)	;! Pick up one word
	AOS	XBP,bup(XBH)
	RETURN
	EPROC
	SUBTTL	inputtext

inputtext:PROC
	inputword
	IF	;! NOTEXT
		JUMPN	FALSE
	THEN	;! No more input
		SETZB	XWAC1,XWAC2
	ELSE	;! Allocate a new text and copy to it from file
		L	XWAC1,
		EXEC	TXBL
		XWD	0,0
		pointers
		LF	XLI,ZTELEN(XWAC1)
		SUBI	XLI,2
		LI	X2,2(XWAC1)	;! Start of text
		IMULI	XLI,5
		inputmove
	FI
	RETURN
	EPROC
	SUBTTL	inputarray

inputarray:
	PROC
	L	X1,XWAC1
	LF	X2,ZARSUB(X1)
	IMULI	X2,3
	ADDI	X2,3
	;! Number of words
	LF	XLI,ZARLEN(X1)
	SUBI	XLI,(X2)
	ADDI	X2,(X1)
	LF	,ZARTYP(X1)
	IF	;! Value type
		CAIL	QTEXT
		GOTO	FALSE
	THEN	;! Copy the whole array directly from file
		IMULI	XLI,5
		inputmove
	ELSE	;! TEXT or REF array
		CAIE	QTEXT
		GOTO	L9	;! Do not output REF array at all
		LOWADR
		objad==YSUPCP
		ST	XWAC1,objad(XLOW)
		MOVNI	XPT,(XLI)
		MOVSS	XPT
		HRRI	XPT,(X2)
		SUBI	XPT,(XWAC1)
		STACK	XPT
		LOOP
			ST	XPT,(XPDP)
			inputtext
			LOWADR
			HRRZ	X1,objad(XLOW)
			ADDI	X1,(XPT)
			STD	XWAC1,(X1)
		AS
			AOBJP	XPT,.+1
			AOBJN	XPT,TRUE
		SA
		UNSTK
		SETZM	objad(XLOW)
	FI
L9():!	RETURN
	EPROC	;! inputarray
	SUBTTL	inputref

	XREF==XPT;! Points to class object
	XMP==XM	;! Map pointer
	XPR==X10;! Prototype pointer

	OPDEF	loadref	[HRRZ XREF,@nextparam(XCB)]

inputref:	PROC
	LD	@nextparam(XCB)
	LF	XPR,ZFLZQU	;! Prototype
	IF	;! Object contains protected attributes on or outside this level
		IFOFF	ZCPPTA(XPR)
		GOTO	FALSE
	THEN	;! Cannot input it
		inputerr 5,Class obj contains protected attributes
		BRANCH	L9
	FI
	ST	XWAC1,@nextparam(XCB)	;! Save object address
	
L1():!	loadref
	inputword
	CAIN	NONE
	GOTO	L9	;! Nothing to read if only output was NONE
	IF	;! Identical prototype
		CAIE	(XPR)
		GOTO	FALSE
	THEN	;! No further check should be needed
		;! No code for this case yet
		NOP
	FI
	LF	X2,ZCPPRL(XPR)	;! Prefix level
	LF	XK,ZPCNRP(XPR)	;! Number of parameters
	L	X1,XK
	HRL	X1,X2
	inputword	;! PRL,,NRP
	IF	;! Different
		CAME	X1
		GOTO	FALSE
	THEN	;! Number of parameters may possibly be different
		XOR	X1
		IF	;! Prefix levels differ
			TLNN	-1
			GOTO	FALSE
		THEN	;! Error
			inputerr	8,inputref wrong prefix level
			GOTO	L9
	FI	FI

	IF	;! We have any parameters
		JUMPE	XK,FALSE
	THEN	;! check that descriptors match except for REF
		LI	XL,OFFSET(ZPCZFP)(XPR)
		LOOP
			LF	X1,ZTDTYP(XL)
			IF	;! Not REF
				CAIN	X1,QREF
				AOJA	XL,FALSE	;! Skip extra word also
			THEN ;! input
				inputword
				XOR	(XL)
				IF	;! First half does not match
					TLNN	-1
					GOTO	FALSE
				THEN	;! Error
					inputerr	8, inputref par mismatch
					GOTO	L9
			FI	FI
			ADDI	XL,1
		AS
			SOJG	XK,TRUE
		SA
		inputword	;! This word should be zero
		IF	;! Not zero
			JUMPE	FALSE
		THEN	;! Error
			inputerr	8,inputref par mismatch
			GOTO	L9
		FI
	FI

	;! input and check map for this prefix level

	LF	XMP,ZPRMAP(XPR)	;! Point to map
	WLF	X1,ZMPNOV(XMP)
	inputword
	IF	;! [227] Map pointer is zero
		JUMPN	XMP,FALSE
	THEN	;! Must match with -1 now
		AOJE	L2
		inputerr 8,Object structure error
	FI
	CAMN	[-1]	;! [227]
	SETZ		;! [227] Force error if no map on output
	XOR	X1
	TLNE	-1
	BRANCH	[inputerr	8,wrong number of non-refs non-arrays
		GOTO	L9()]
	WLF	X1,ZMPNTX(XMP)
	inputword
	XOR	X1
	TLNE	-1
	BRANCH	[inputerr	8,wrong number of texts
		GOTO	L9()]

	;! Identify arrays

	WLF	XL,ZMPNRV(XMP)
	IF	;! Any REF and/or ARRAY
		JUMPE	XL,FALSE
	THEN	;! Find all arrays, input and check identification for non-REF arrays
		ADDI	XL,(XREF)	;! AOBJN word
		LOOP
			L	XM,(XL)
			IF	;! non-REF ARRAY
				CAIN	XM,NONE
				GOTO	FALSE
				LF	,ZDNTYP(XM)
				CAIE	QZAR
				GOTO	FALSE
				LF	,ZARTYP(XM)
				CAIN	QREF
				GOTO	FALSE
			THEN	;! input size, nsub, type in one word
				LF	X1,ZARLEN(XM)
				HLL	X1,OFFSET(ZARSUB)(XM)	;![126]
				inputword
				CAME	X1
				BRANCH	[inputerr 8,array not compatible
					GOTO	L9()]
			FI
		AS
			INCR	XL,TRUE
		SA
	FI
	;! Final zero closes array specs
	inputword
	JUMPN	[inputerr 0,phase error inputref
		GOTO	L9()]

	;! Handle prefix chain
L2():!	LF	XPR,ZCPZCP(XPR)
	JUMPN	XPR,L1
	inputword		;! End of identification list
	JUMPN	[inputerr 0,phase error inputref
		GOTO	L9()]
	SUBTTL	inputref, input of attribute values

	;! input of values for one prefix level
	;! -------------------------------------

	loadref
	LD	@nextparam(XCB)
	LF	XPR,ZFLZQU
L4():!	LF	XK,ZPCNRP(XPR)	;! [227] Go here for each prefix level
	IF	;! Parameters exist
		JUMPE	XK,FALSE
	THEN	;! input all but REF
		MOVNI	(XK)
		LI	XK,OFFSET(ZPCZFP)(XPR)
		HRLM	XK
		LOOP
			LF	X1,ZTDTYP(XK)
			IF	;! NOT REF
				CAIN	X1,QREF
				GOTO	FALSE
			THEN
				LF	,ZPDKND(XK)
				IF	;! ARRAY
					CAIE	QARRAY
					GOTO	FALSE
				THEN
					LF	X2,ZFPOFS(XK)	;![126]
					ADDI	X2,(XREF)	;![126]
					L	XWAC1,(X2)
					inputarray
					loadref
				ELSE
					CAIE	QSIMPLE
					RFAIL	inputref wrong par kind
					IF	;! Simple value type
						CAIL	X1,QTEXT
						GOTO	FALSE
					THEN
						inputword
						LF	X2,ZFPOFS(XK)	;![126]
						ADDI	X2,(XREF)	;![126]
						ST	(X2)
						IF	;! LONG REAL
							CAIE	X1,QLREAL
							GOTO	FALSE
						THEN	inputword
							ST	1(X2)
						FI
					ELSE	;! Must be TEXT
						CAIE	X1,QTEXT
						RFAIL	inputref wrong par type
						inputtext
						loadref
						LF	X2,ZFPOFS(XK)	;![126]
						ADDI	X2,(XREF)	;![126]
						STD	XWAC1,(X2)	;![126]
				FI	FI
			ELSE	;! Skip extra word
				AOS	XK
			FI
		AS
			INCR	XK,TRUE
		SA
	FI
	;! Now input attributes according to map
	;!---------------------------------------

	LF	XMP,ZPRMAP(XPR)
	JUMPE	XMP,L8		;! [227]
	LFE	XLI,ZMPNOV(XMP)
	LFE	XK,ZMPNTX(XMP)
	SUB	XLI,XK	;! Number of non-ref, non-text, non-array variables
	IF	;! Any such variables
		JUMPE	XLI,FALSE
	THEN	;! input them all via inputmove
		LF	X2,ZMPDOV(XMP)
		ADDI	X2,(XREF)
		MOVMS	XLI
		IMULI	XLI,5	;! Number of characters
		inputmove
	FI

	IF	;! Any TEXT
		WLF	XK,ZMPNTX(XMP)
		JUMPE	XK,FALSE
	THEN
		LOOP
			inputtext
			loadref	;! Restore XREF in case of GC
			L	X1,XREF		;![126]
			ADDI	X1,(XK)		;![126]
			STD	XWAC1,(X1)	;![126]
		AS
			AOBJP	XK,.+1
			AOBJN	XK,TRUE
		SA
	FI

	;! Input any arrays

	WLF	XL,ZMPNRV(XMP)
	IF	;! Any REF and/or ARRAY
		JUMPE	XL,FALSE
	THEN	;! Find all arrays, input values for non-REF arrays
		ADDI	XL,(XREF)	;! AOBJN word
		LOOP
			L	XWAC1,(XL)
			IF	;! non-REF ARRAY
				CAIN	XWAC1,NONE
				GOTO	FALSE
				LF	,ZDNTYP(XWAC1)
				CAIE	QZAR
				GOTO	FALSE
				LF	,ZARTYP(XWAC1)
				CAIN	QREF
				GOTO	FALSE
			THEN	;! Input values
				inputarray
			FI
		AS
			AOBJN	XL,TRUE
		SA
	FI
	;! Final zero closes array specs
	inputword
	JUMPN	[inputerr	0,phase error inputref
		GOTO	L9()]

L8():!	LF	XPR,ZCPZCP(XPR)
	JUMPN	XPR,L4

L9():!	RETURN
	EPROC
	SUBTTL	newbuffer

newbuffer:
	PROC
	SAVE	<X0,X1,X2,XWAC1>
	HRRZ	XWAC1,fileref(XCB)
	SETON	ZFINB(XWAC1)
	READBLOCK
	SETOFF	ZFINB(XWAC1)
	L	XBP,bup(XBH)
	IFON	ZFIEND(XWAC1)
	BRANCH	inpeof
	RETURN
	EPROC
	SUBTTL	inputmove

inputmove:PROC
	IF	;! Only one word
		CAILE	XLI,5
		GOTO	FALSE
	THEN	;! Use inputword
		inputword
		ST	(X2)
		RETURN
	FI
	SAVE	<X2,XJ,XK,XLI>
L1():!	SETZ	XJ,	;! No truncation yet
	L	XK,XLI
	SKIPG	cnt(XBH)
	NEWBUFFER
	IF	;! Buffer does not have it all
		CAMG	XK,cnt(XBH)
		GOTO	FALSE
	THEN	;! Move what fits
		L	XK,cnt(XBH)
		SUBI	XLI,(XK)
		HRROS	XJ	;! Flag truncation
	FI
	L	XK
	IDIVI	5
	ST	XK
	IMULI	5
	ADDM	count(XCB)
	MOVNS
	ADDM	cnt(XBH)

	;! BLT word in X0
	L	XBP,bup(XBH)
	normalize(XBP)
	LI	(X2)
	HRLI	(XBP)
	ADDI	XBP,(XK)
	ADDI	X2,(XK)
	ST	XBP,bup(XBH)
	BLT	-1(X2)	;! Move info
	JUMPL	XJ,L1
	RETURN
	EPROC
	SUBTTL	inputerr

.inputerr:PROC
	SAVE	X1
	N==1	;! One saved value on stack
	Outstr	[ASCIZ/input error /]
	HLRZ	X1,@-N(XPDP)
	Outchr	X1
	Outstr	[ASCIZ/, /]
	HRRZ	X1,@-N(XPDP)
	Outstr	(X1)
	Outstr	[ASCIZ/
/]
	HRRZ	XWAC1,fileref(XCB)
	ERRFILE
	RTSERR	QDSCON,214	;! ??
	AOS	-N(XPDP)	;! Skip return
	HRROS	count(XCB)	;! Signal error exit
	RETURN
	EPROC

	LIT
	END;