Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-03 - decus/20-0078/libsim/output.mac
There are 2 other files named output.mac in the archive. Click here to see a list.
COMMENT * SIMULA specification;
OPTIONS(/E:CODE,NOCHECK,output);
INTEGER PROCEDURE output;!(fileref,[[,item]...]);
COMMENT outputs successive items on a file which is IN Outfile
or Directfile. Image is not used - output is directly to the buffers;

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

	ifndef	qpz,<qpz==0>	;! Default - generate output rel file
	ife	qpz,<
	TITLE	output
	ENTRY	output
	>
	ifn	qpz,<	;! Generate putsize.rel from this file if qpz=/=0
	TITLE	putsize
	ENTRY	putsize
	>
	search	simmac,simmcr,simrpa
	sall
	macinit
	SUBTTL	SIMULA utility, Lars Enderin Nov 1975

;!*** Copyright 1975 by the Swedish Defence Research Institute. ***
;!*** Copying is allowed.					***


	DF BYTESIZE,0,6,11	;! Byte size field of byte pointer
	count==ZBI%S
	fileref==ZBI%S+1
	nextparam==fileref+1
	firstpar==fileref+2

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

	ops	<puttext,putref,putarray>
	ife	qpz,<
	ops	<pointers,putword,newbuffer,putmove,wordcount>
	>

	XSP==	13
	XBH==	7
	XFIL==	XWAC3
	XBP==	XWAC4
	XLI==	XL
	XPT==	14
	maxoffset==^d31

	ifn	qpz,<
	nextparam==maxoffset+1
	maxoffset==maxoffset-2
	firstpar==fileref
	opdef	putword	[AOS	count(XCB)]
	opdef	putmove [ADDM	XLI,count(XCB)]
	define	pointers	<>
	define	errfile	<>
	>

	cnt==OFFSET(ZBHCNT)
	bup==OFFSET(ZBHBUP)

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

	ife qpz,<
	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]
	>
ife qpz,<

	SUBTTL	output

output:	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
		CAIN	X2,IOPF	;! Printfile disallowed
		GOTO	FALSE
		CAIE	X2,IOOU	;! Outfile or
		CAIN	X2,IODF	;! Directfile are
		GOTO	L1	;! Ok!
		LF	X2,ZCPZCP(X2)
	AS	;! long as there is a prefix
		JUMPN	X2,TRUE
	SA
	puterr	3,Wrong file type
	GOTO	PUTEND
L1():!	L	[Z	firstpar(XCB)]
	ST	nextparam(XCB)
	IF	;! Directfile
		CAIE	X2,IODF
		GOTO	FALSE
	THEN	SETON	ZDFOUT(XWAC1)	;! Signal output (not input)
		IF	;! First output or input after Locate
			IFON	ZFIPGT(XWAC1)
			GOTO	FALSE
		THEN	;! Must get 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	;! Outfile
		L	XFIL,XWAC1
		LF	XBH,ZFIOBH(XFIL)
		SUBI	XBH,1
		L	XBP,bup(XBH)
		IF	;! First put after Outimage, but not first output
			L	OFFSET(ZFIPGT)(XFIL)
			IFONA	ZFIPGT
			GOTO	FALSE
			IFOFFA	ZFILBO
			IFONA	ZFIFO
			GOTO	FALSE
		THEN	;! Insert line feed
			SOSGE	cnt(XBH)
			NEWBUFFER
			LI	QLF
			IDPB	XBP
			SETON	ZFIPGT(XFIL)
		FI
		WHILE	;! Not on a word boundary
			TLNN	XBP,300000
			GOTO	FALSE
		DO	IBP	XBP
			SOS	cnt(XBH)
		OD
		ST	XBP,bup(XBH)
	FI
;! Handle one parameter here
;! -------------------------

L2():!	pointers
	IF	;! File is not open
		IFON	ZFIOPN(XFIL)
		GOTO	FALSE
	THEN	puterr	4,File not open
		BRANCH	PUTEND
	FI
	>	;! end of ife
ifn	qpz,<
putsize:PROC
	L	[Z	firstpar(XCB)]
	ST	nextparam(XCB)
L2():!
	>	;! end of ifn
	LD	XWAC1,@nextparam(XCB)
	JUMPE	XWAC1,PUTEND
	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 value directly
			ADDI	XWAC2,(XWAC1)
			LD	XWAC1,(XWAC2)
		ELSE	;! via PHFV
			LI	XWAC1,(XCB)
			HRL	XWAC1,nextparam(XCB)
			EXEC	PHFV
			XWD	0,0
			L	@nextparam(XCB)
			LF	X2,ZFLATP
			pointers	;! reconstructed
		FI
		L	XWAC1
		IF	;! Long real
			CAIE	X2,QLREAL
			GOTO	FALSE
		THEN	putword
			L	XWAC2
			putword
		ELSE
		IF	;! Simple value type
			CAIL	X2,QTEXT
			GOTO	FALSE
		THEN	putword
		ELSE
		IF	;! TEXT
			CAIE	X2,QTEXT
			GOTO	FALSE
		THEN	puttext
		ELSE
		IF	;! REF
			CAIE	X2,QREF
			GOTO	FALSE
		THEN	PUTREF
		ELSE	;! Wrong type
			puterr	1,Wrong type
		FI	FI	FI	FI
	ELSE	;! Not of simple kind, may be array or parameterless procedure
		CAIN	X1,QPROCEDURE
		GOTO	L3		;! Must be parameterless if proc
		IF	;! Array
			CAIE	X1,QARRAY
			GOTO	FALSE
		THEN	LI	XWAC1,(XCB)
			HRL	XWAC1,nextparam(XCB)
			EXEC	PHFM
			XWD	0,0
			pointers	;! reconstructed
			putarray
		ELSE
			puterr	2,Wrong kind
	FI	FI

	HRRZ	nextparam(XCB)
	ADDI	2
	HRRM	nextparam(XCB)
	CAILE	maxoffset
	GOTO	PUTEND

ife qpz,<

	IFOFF	ZFIDF(XFIL)
	GOTO	L2

	;! Update word count for Directfile
	wordcount
	SETON	ZDFMOD(XFIL)	;! Mark buffer as modified
>
	GOTO	L2	;! Fetch next parameter

PUTEND:	;! Restore XPDP to stack bottom
	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
	IMULI	5	;! Number of char's per word
	ST	count(XCB)
ife qpz,<
	;! Adjust ZDFLIM for directfile

	IFOFF	ZFIDF(XFIL)	;![130]
	GOTO	L9
	pointers
	wordcount	;! X0 = words written by output in THIS block
	LF	X2,ZDFIML(XFIL)
	ADDI	X2,4
	IDIVI	X2,5	;! Number of words per image
	LF	X3,ZDFBLK(XFIL)	;! Current disk block
	SUBI	X3,1
	IMULI	X3,200	;! Number of words in all preceding blocks
	;! Number of words written in X0 from wordcount call
	ADD	X3	;![130]
	ADDI	-1(X2)	;! Rounding upwards
	IDIVI	(X2)	;! Gives number of last written image now
	LF	X1,ZDFLIM(XFIL)
	CAILE	(X1)
>
	SF	,ZDFLIM(XFIL)
L9():!	pointers	;![126]
	IF	;![126] Byte pointer is too large
		TLNN	XBP,400000
		GOTO	FALSE
	THEN	;! Make it point to last word written
		SUBI	XBP,1
		HRLI	XBP,010700
		ST	XBP,bup(XBH)
	FI	;![126]
	BRANCH	CSEP
	EPROC	;! output or putsiz
ife qpz,<

	SUBTTL	pointers

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

wordcount:
	LI	(XBP)	;! Addr of last written word+1
	LF	X1,ZBHZBU(XBH)
	SUBI	2(X1)	;! Length of data in buffer (words)
	LF	X1,ZDFWCT(XFIL)
	CAIL	(X1)
	SF	,ZDFWCT(XFIL)
	RETURN
	SUBTTL	putword

putword:PROC
	SKIPG	cnt(XBH)
	NEWBUFFER
	ST	(XBP)	;! Store the word
	MOVNI	5
	ADDM	cnt(XBH)
	AOS	XBP,bup(XBH)
	AOS	count(XCB)
	RETURN
	EPROC
	SUBTTL	puttext

puttext:PROC
	SAVE	<XSP,XPT>
	LF	XLI,ZTVLNG(,XWAC1)
	L	XLI
	putword	;! Number of characters only
	IF	;! NOT NOTEXT
		JUMPLE	XLI,FALSE
	THEN	;! Handle text
		LF	X2,ZTVZTE(,XWAC1)
		ADDI	X2,2
		LF	XSP,ZTVSP(,XWAC1)
		IF	;! Non-zero offset
			JUMPE	XSP,FALSE
		THEN	;! Update adress, offset less than 5
			IDIVI	XSP,5
			ADDI	X2,(XSP)
			L	XSP,XSP+1
		FI
		IF	;! Word aligned text and enough to bother
			JUMPN	XSP,FALSE
			CAIGE	XLI,6*5	;! 6 words enough??
			GOTO	FALSE
		THEN	;! Use putmove
			L	XLI
			IDIVI	5
			IMULI	5
			ST	XLI
			STACK	X1	;! Number of remaining char's at end
			putmove
			UNSTK	XLI	;! Remaining number of char's in text
			JUMPLE	XLI,L9
		FI
		LOOP	;! Output characters properly shifted into words
			L	(X2)
			IF	JUMPE	XSP,FALSE
			THEN	L	X1,1(X2)
				LSH	-1
				XCT	shift(XSP)
				TRZ	1
			FI
			CAIG	XLI,4
			AND	mask(XLI)
			putword
		AS
			SUBI	XLI,5
			ADDI	X2,1
			JUMPG	XLI,TRUE
		SA
	FI
L9():!	RETURN
	EPROC


shift=.-1
	LSHC	1*7+1
	LSHC	2*7+1
	LSHC	3*7+1
	LSHC	4*7+1
mask=.-1
	q==177
	BYTE	(7)Q,0,0,0,0(1)0
	BYTE	(7)Q,Q,0,0,0(1)0
	BYTE	(7)Q,Q,Q,0,0(1)0
	BYTE	(7)Q,Q,Q,Q,0(1)0
>

ifn qpz,<

puttext:LF	,ZTVLNG(,XWAC1)
	ADDI	1*5+5-1
	IDIVI	5
	ADDM	count(XCB)
	RETURN
>
	SUBTTL	putarray

putarray:
	PROC
	SAVE	<XPT>
	LF	X2,ZARSUB(XWAC1)
	IMULI	X2,3
	ADDI	X2,3
	;! Number of words
	LF	XLI,ZARLEN(XWAC1)
	SUBI	XLI,(X2)
	ADDI	X2,(XWAC1)
	LF	,ZARTYP(XWAC1)
	IF	;! Value type
		CAIL	QTEXT
		GOTO	FALSE
	THEN	;! Copy the whole array directly to file
		ife qpz,<
		IMULI	XLI,5
		>
		putmove
	ELSE	;! TEXT or REF array
		CAIE	QTEXT
		GOTO	L9	;! Do not output REF array at all
		MOVNI	XPT,(XLI)
		MOVSS	XPT
		HRRI	XPT,(X2)
		LOOP
			LD	XWAC1,(XPT)
			puttext
		AS
			AOBJP	XPT,.+1
			AOBJN	XPT,TRUE
		SA
	FI
L9():!	RETURN
	EPROC	;! putarray
	SUBTTL	putref

	XREF==XPT;! Points to class object
	XMP==XM	;! Map pointer
	XPR==X10;! Prototype pointer
putref:	PROC
	IF	;! NONE
		CAIE	XWAC1,NONE
		GOTO	FALSE
	THEN	;! Just output NONE
		LI	NONE
		putword
		GOTO	L9
	FI
	LD	@nextparam(XCB)
	LF	XPR,ZFLZQU	;! Prototype
	IF	;! Object contains protected attributes on or outside this level
		IFOFF	ZCPPTA(XPR)
		GOTO	FALSE
	THEN	;! Cannot output it
		puterr	5,Class obj contains potected attributes
		BRANCH	L9
	FI
	ST	XWAC1,@nextparam(XCB)	;! Save object address
	
L1():!	HRRZ	XREF,@nextparam(XCB)
	L	XPR	;! Identify by prototype address - to be elaborated
	putword
	LF	X2,ZCPPRL(XPR)	;! Prefix level
	LF	XK,ZPCNRP(XPR)	;! Number of parameters
	L	XK
	HRL	X2
	putword	;! PRL,,NRP

	IF	;! We have any parameters
		JUMPE	XK,FALSE
	THEN	;! Output all descriptors (ZFP) except REF
		LI	XL,OFFSET(ZPCZFP)(XPR)
		LOOP
			L	(XL)
			LF	X1,ZTDTYP
			IF	;! Not REF
				CAIN	X1,QREF
				AOJA	XL,FALSE	;! Skip extra word also
			THEN ;! Output
				putword
			FI
			ADDI	XL,1
		AS
			SOJG	XK,TRUE
		SA
		SETZ
		putword	;! Zero to mark end of parameter descriptors
	FI

	;! Output map for this prefix level

	LF	XMP,ZPRMAP(XPR)	;! Point to map
	IF	;! [227] No map
		JUMPN	XMP,FALSE
	THEN	;! Output -1
		SETO
		putword
		GOTO	L2	;! Directly to prefix if any
	FI	;! [227]
	WLF	,ZMPNOV(XMP)
	putword
	WLF	,ZMPNTX(XMP)
	putword

	;! Identify arrays

	WLF	XL,ZMPNRV(XMP)
	IF	;! Any REF and/or ARRAY
		JUMPE	XL,FALSE
	THEN	;! Find all arrays, output identification for non-REF arrays
		ADDI	XL,(XREF)	;! AOBJN word
		LOOP
			L	XM,(XL)
			IF	;! ARRAY
				CAIN	XM,NONE
				GOTO	FALSE
				LF	,ZDNTYP(XM)
				CAIE	QZAR
				GOTO	FALSE
			THEN	;! Output size, nsub, type in one word
				LF	,ZARLEN(XM)
				HLL	OFFSET(ZARSUB)(XM)
				LF	X1,ZARTYP(XM)
				CAIE	X1,QREF	;! Ignore REF array
				putword
			FI
		AS
			AOBJN	XL,TRUE
		SA
	FI
	;! Final zero closes array specs
	SETZ
	putword

L2():!	;! Handle prefix chain
	LF	XPR,ZCPZCP(XPR)
	JUMPN	XPR,L1
	SETZ
	putword		;! End of identification list = 0
	SUBTTL	putref, output of attribute values

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

	HRRZ	XREF,@nextparam(XCB)
	LD	@nextparam(XCB)
	LF	XPR,ZFLZQU
L4():!	LF	XK,ZPCNRP(XPR)
	IF	;! Parameters exist
		JUMPE	XK,FALSE
	THEN	;! Output all but REF
		MOVNI	(XK)
		LI	XK,OFFSET(ZPCZFP)(XPR)
		HRLM	XK
		LOOP
			LF	X1,ZTDTYP(XK)
			IF	;! NOT REF
				CAIN	X1,QREF
				AOJA	XK,FALSE	;! Skip one word
			THEN
				LF	X2,ZFPOFS(XK)
				ADDI	X2,(XREF)
				LF	,ZPDKND(XK)
				IF	;! ARRAY
					CAIE	QARRAY
					GOTO	FALSE
				THEN
					L	XWAC1,(X2)
					putarray
				ELSE
					CAIE	QSIMPLE
					RFAIL	putref wrong par kind
					IF	;! Simple value type
						CAIL	X1,QTEXT
						GOTO	FALSE
					THEN
						L	(X2)
						putword
						IF	;! LONG REAL
							CAIE	X1,QLREAL
							GOTO	FALSE
						THEN	L	1(X2)
							putword
						FI
					ELSE	;! Must be TEXT
						CAIE	X1,QTEXT
						RFAIL	putref wrong par type
						LD	XWAC1,(X2)
						puttext
			FI	FI	FI
		AS
			INCR	XK,TRUE
		SA
	FI
	;! Now output attributes according to map
	;!---------------------------------------

	LF	XMP,ZPRMAP(XPR)
	JUMPE	XMP,L8		;! [227] No output if no map
	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	;! Output them all via putmove
		LF	X2,ZMPDOV(XMP)
		ADDI	X2,(XREF)
		MOVMS	XLI
		ife qpz,<
		IMULI	XLI,5	;! Number of characters
		>
		putmove
	FI

	IF	;! Any TEXT
		WLF	XK,ZMPNTX(XMP)
		JUMPE	XK,FALSE
	THEN
		ADDI	XK,(XREF)	;! AOBJN word
		LOOP
			LD	XWAC1,(XK)
			puttext
		AS
			AOBJP	XK,.+1
			AOBJN	XK,TRUE
		SA
	FI

	;! Output any arrays

	WLF	XL,ZMPNRV(XMP)
	IF	;! Any REF and/or ARRAY
		JUMPE	XL,FALSE
	THEN	;! Find all arrays, output values for non-REF arrays
		ADDI	XL,(XREF)	;! AOBJN word
		LOOP
			L	XWAC1,(XL)
			IF	;! ARRAY
				CAIN	XWAC1,NONE
				GOTO	FALSE
				LF	,ZDNTYP(XWAC1)
				CAIE	QZAR
				GOTO	FALSE
				LF	,ZARTYP(XWAC1)
				CAIN	QREF
				GOTO	FALSE
			THEN	putarray
			FI
		AS
			AOBJN	XL,TRUE
		SA
	FI
	;! Final zero closes array specs
	SETZ
	putword

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

L9():!	RETURN
	EPROC
ife qpz,<

	SUBTTL	newbuffer

newbuffer:
	PROC
	SAVE	<X0,X1,X2,XWAC1,XLI>
	L	XWAC1,fileref(XCB)
	LI	X1,200
	IFON	ZFIDF(XWAC1)
	SF	X1,ZDFWCT(XWAC1)
	SKIPG	cnt(XBH)	;! IONB returns here!
	EXEC	IONB
	L	XBP,bup(XBH)
	RETURN
	EPROC
	SUBTTL	putmove

putmove:PROC
	IF	;! Only one word
		CAILE	XLI,5
		GOTO	FALSE
	THEN	;! Use putword
		L	(X2)
		BRANCH	putword
	FI
	SAVE	<XJ,XK,XLI>
L1():!	SETZ	XJ,	;! No truncation yet
	L	XK,XLI
	SKIPG	cnt(XBH)
	NEWBUFFER
	IF	;! Buffer cannot take 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
	MOVNS
	ADDM	cnt(XBH)

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

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

	LIT
	END;