Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/libsim/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;