Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-05 - 43,50337/23/write.mac
There are 2 other files named write.mac in the archive. Click here to see a list.
COMMENT ! SIMULA specification;
OPTIONS(/EXTERNAL:CODE,NOCHECK,write);
PROCEDURE write;

!;! MACRO-10 code !

	TITLE	write
	SUBTTL	SIMULA utility, Lars Enderin Sept, Nov 1975

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

	SEARCH	simrpa,simmcr,simmac
	sall
	macinit

DEFINE error(n)<;![234]
	JSP	werr
	CAI	n>

	ENTRY	write

Comment/
Writes items from successive parameters to the current Outfile or Directfile.
The current file is initially SYSOUT,    but may be changed by giving another
Outfile or Directfile reference as parameter.     The other parameters may be
of type INTEGER, REAL, LONG REAL, CHARACTER or TEXT. Outint, Outreal, Outchar
or Outtext is used depending on the parameter type.    Since the procedure is 
specified NOCHECK, all parameters are passed by name.
In addition to simple values, arrays may also be output, i e the elements are
output in storage order.
/
	DEFINE	NOTHUNK(X)<JUMPGE X,FALSE>
	Xtyp==XWAC10
	Xkind==Xtyp+1
	XN==Xkind+1

	OPDEF	outitem	[PUSHJ	XPDP,outitem]


write:
	PROC
	LOWADR
	L	XWAC2,YSYSOUT(XLOW)	;! Default output file
	HRLI	XWAC1,2			;! Dynamic addr of ZFL
	HRRI	XWAC1,(XCB)

	WHILE	;! More parameters
		CAML	XWAC1,[^D32+1,,0]
		GOTO	FALSE
		HLRZ	X1,XWAC1
		ADDI	X1,(XWAC1)	;! abs addr of ZFL
		SKIPN	(X1)		;! No more if ZFL=0
		GOTO	FALSE
	DO
		WLF	,ZFLATP(X1)
		LF	Xtyp,ZFLATP
		LF	Xkind,ZFLAKD
		IF	;! type is REF
			CAIE	Xtyp,QREF
			GOTO	FALSE
		THEN	;! It has to be Outfile, Printfile or Directfile
			IF	;! Not first parameter
				CAMG	XWAC1,[3,,0]
				GOTO	FALSE
			THEN	;! Outimage on old file
				ST	XWAC1,2(XCB)
				L	XWAC1,XWAC2
				EXEC	IOOG
				L	XWAC1,2(XCB)
			FI
			CAIE	Xkind,QSIMPLE	;! Kind must be simple
			error	113
			L	XWAC2,XWAC1
			EXEC	PHFV		;! Get ref
			XWD	1,[1B0]		;! preserves ZFL address
			IF	;! NONE
				CAIE	XWAC2,NONE
				GOTO	FALSE
			THEN	;! Assume Sysout
				LOWADR
				L	XWAC2,YSYSOUT
			ELSE
				HLRZ	X1,XWAC1
				ADDI	X1,(XWAC1)
				LF	,ZFLZQU(X1)
				IF	;! Not Outfile or Printfile or Directfile
					CAIE	IOPF
					CAIN	IOOU
					GOTO	FALSE
					CAIN	IODF
					GOTO	FALSE
				THEN	;! Error!
					error	111
			FI	FI
		ELSE
			IF
				NOTHUNK
			THEN	;! Compute parameter value directly
				LF	XWAC3,ZFLOFS(X1)
				ADD	XWAC3,OFFSET(ZFLZBI)(X1)
				CAIE	Xkind,QARRAY
				CAIN	Xkind,QSIMPLE
				LD	XWAC3,(XWAC3)
			ELSE	;! Evaluate thunk for the value
				L	XWAC3,XWAC1
				LI	X1,PHFM
				CAIE	Xkind,QPROCEDURE
				CAIN	Xkind,QSIMPLE
				LI	X1,PHFV
				EXEC	0(X1)
				XWD	2,[1B0+1B1]	;! Preserve XWAC1,XWAC2
				HLRZ	X1,XWAC1	;! Reload X1, Xtyp, Xkind
				ADDI	X1,(XWAC1)
				LF	Xtyp,ZFLATP(X1)
				LF	Xkind,ZFLAKD(X1)
			FI
			STACK	XWAC1
			IF	;! Kind is simple or procedure
				CAIE	Xkind,QSIMPLE
				CAIN	Xkind,QPROCEDURE
				GOTO	TRUE
				GOTO	FALSE
			THEN	;! Output one item
				outitem
			ELSE	;! Must be array
				CAIE	Xkind,QARRAY
				error	113
				LF	XN,ZARSUB(XWAC3)
				IMULI	XN,3
				LF	,ZARLEN(XWAC3)
				SUBI	3(XN)
				MOVN		;! Neg count
				ADDI	XN,3(XWAC3)
				HRLM	XN	;! AOBJN word
				IF	;! TEXT or LONG REAL
					CAIE	Xtyp,QTEXT
					CAIN	Xtyp,QLREAL
					GOTO	TRUE
					GOTO	FALSE
				THEN	;! 2 words at a time
					LOOP
						LD	XWAC3,(XN)
						outitem
					AS
						AOBJP	XN,.+1
						AOBJN	XN,TRUE
					SA
				ELSE	;! One word
					LOOP
						L	XWAC3,(XN)
						outitem
					AS
						AOBJN	XN,TRUE
					SA
			FI	FI
			UNSTK	XWAC1
		FI
		ADD	XWAC1,[2,,0]
	OD
	L	XWAC1,XWAC2
	EXEC	IOOG		;! Outimage finishes output on file
	BRANCH	CSES
	EPROC


;! [234] ;!

werr:	;! Set up error as if it occurred at the call on write not to confuse
	;! SIMDDT

	HRRZ	@	;! Error code
	HRLI	(RTSERR)
	ST	.JBUUO##
	HRRI	XPDP,YOBJRT-1(XLOW)	;! Reset stack
	HRLI	XPDP,-QPDLEN
	LF	,ZDRARE(XCB)	;! Address of call
	STACK
	LF	XCB,ZDRZBI(XCB)	;! Reset XCB also
	BRANCH	OCUU		;! Faked error UUO
outitem:
	PROC
	L	XWAC1,XWAC2
	IF	;! INTEGER
		CAIE	Xtyp,QINTEGER
		GOTO	FALSE
	THEN	;! use Outint
		LI	XWAC4,^D12	;! 12 digits
		EXEC	IOOI
	ELSE
	IF	;! REAL
		CAIE	Xtyp,QREAL
		GOTO	FALSE
	THEN	;! use Outreal or Outfix
		SETZ	XWAC4,		;! Extend to long real
		SKIPGE	XWAC3
		HRLOI	XWAC4,377777
		LI	XWAC5,d
		LI	XWAC6,w
		IF	;! value is zero
			JUMPN	XWAC3,FALSE
		THEN	;! Outfix(x,0,w)
			SETZ	XWAC5,
			EXEC	IOOX
		ELSE
		MOVM	XWAC3
		IF	;! x>=10^d
			CAMGE	powd
			GOTO	FALSE
		THEN	;! Outreal(x,d,w)
			EXEC	IOOR
		ELSE
		IF	;! x>=10^(-e)
			CAMGE	pow.e
			GOTO	FALSE
		THEN	;! Outfix(x,d-ilog(x),w)
			EXEC	ilog
			MOVNS	XWAC5
			ADDI	XWAC5,d
			EXEC	IOOX
		ELSE	;! Outreal(x,d,w)
			EXEC	IOOR
		FI	FI	FI
	ELSE
	IF	;! LONG REAL
		CAIE	Xtyp,QLREAL
		GOTO	FALSE
	THEN	;! use Outreal or Outfix
		LI	XWAC5,qd
		LI	XWAC6,qw
		IF	;! value is zero
			JUMPN	XWAC3,FALSE
		THEN	;! Outfix(x,0,qw)
			SETZ	XWAC5,
			EXEC	IOOX
		ELSE
			LD	XWAC3
			SKIPGE
			DMOVN	XWAC3
			IF	;! x>=10^qd
				CAMGE	powqd
				GOTO	FALSE
			THEN	;! Outreal(x,qd,qw)
				EXEC	IOOR
			ELSE
			IF	;! x>=10^(-qe)
				DFSB	pow.qe
				JUMPL	FALSE
			THEN	;! Outfix(x,qd-ilog(x),qw)
				EXEC	ilog
				MOVNS	XWAC5
				ADDI	XWAC5,qd
				EXEC	IOOX
			ELSE	;! Outreal(x,qd,qw)
				EXEC	IOOR
		FI	FI	FI
	ELSE
	IF	;! CHARACTER
		CAIE	Xtyp,QCHARACTER
		GOTO	FALSE
	THEN	;! use Outchar
		EXEC	IOOC
	ELSE
	IF	;! TEXT
		CAIE	Xtyp,QTEXT
		GOTO	FALSE
	THEN	;! use Outtext
		EXEC	IOOT
	ELSE	;! Wrong type
		error	107
	FI	FI	FI	FI	FI
	RETURN
	EPROC

;! Constants ;!

d==8		;! Number of significant digits for REAL items
e==4		;! Width of exponent part
w==d+e+2	;! Allow also for sign and decimal point in total width
powd:	DEC	1.0E8	;! 10^d
pow.e:	DEC	1.0E-4	;! 10^(-e)
qd==^d18	;! d for LONG REAL
qw==qd+e+2
powqd:	DEC	1.0E18
pow.qe:	OCT	163643334272,307041454512	;! 10^(-qe)
ilog:	PROC
	x==XWAC3
	i==XWAC5
	LD	x
	SKIPGE
	DMOVN	x
	IF	JUMPE	TRUE
		CAML	E0
		GOTO	FALSE
		CAMLE	[1.0E-1]
		GOTO	TRUE
		DFSB	E.1
		JUMPG	.+3
		DFAD	E.1
		GOTO	FALSE
		DFAD	E.1
	THEN	SETZ	i,
	ELSE
		IF	;! x LT 1
			CAML	E0
			GOTO	FALSE
		THEN	;! Invert x
			STACK
			STACK	X1
			LD	[DEC 1.0E0,0]
			DFDV	-1(XPDP)
			UNSTK	(XPDP)
			UNSTK	(XPDP)
		FI
		DEFINE	m(n,nosub)<
			IFB <nosub>,<
			SUBI i,1
			>
			CAML	E0+'n
			GOTO	L1
			>
		IF	;! LONG REAL
			CAIE	Xtyp,QLREAL
			GOTO	FALSE
		THEN	;! Split interval in two
			DFMP	E.8	;! 10^-8
			LI	i,^d11
			m(^d10,nosub)
			m(9)
			m(8)
		FI
		LI	i,8
		m(7,nosub)
		m(6)
		m(5)
		m(4)
		m(3)
		m(2)
		m(1)
		LI	i,1
	L1():!	IF	;! LONG REAL
			CAIE	Xtyp,QLREAL
			GOTO	FALSE
		THEN
			LD	x
			SKIPGE
			DMOVN	x
			CAML	E8
			ADDI	i,8
		FI
		IF	;! x < 1
			MOVM	x
			CAML	E0
			GOTO	FALSE
		THEN
			MOVNI	i,-1(i)
	FI	FI
	RETURN
	EPROC

E.1:	OCT	175631463146,146314631463
E.8:	OCT	146527461670,214106071675
E0:	DEC	1.0E0,1.0E1,1.0E2,1.0E3,1.0E4,1.0E5,1.0E6,1.0E7
E8:	DEC	1.0E8,1.0E9,1.0E10
	LIT
	END;