Trailing-Edge
-
PDP-10 Archives
-
decuslib10-05
-
43,50337/23/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;