Trailing-Edge
-
PDP-10 Archives
-
decuslib20-04
-
decus/20-0135/comp/pgcopy.mac
There are 2 other files named pgcopy.mac in the archive. Click here to see a list.
00100 COMMENT * pgcopy, SIMULA specification;
00200 OPTIONS(/E:QUICK,pgcopy);
00300 PROCEDURE pgcopy(inf,outf,numbered);
00400 REF(Infile)inf; REF(Outfile)outf;
00500 BOOLEAN numbered;
00600 COMMENT Copies characters from INF to OUTF, returning on end of
00700 page (form feed seen) or inf.Endfile only.
00800 Special case: If OUTF == NONE, no output will be done.
00900 ;
01000
01100 !*;! MACRO-10 code !*;!
01200
01300 TITLE pgcopy
01400 ENTRY pgcopy
01500 SUBTTL SIMULA utility, Lars Enderin Feb 1979
01600
01700 ;!*** Copyright 1979 by the Swedish Defence Research Institute. ***
01800 ;!*** Copying is allowed. ***
01900
02000
02100 sall
02200 search simmac,simmcr,simrpa
02300 macinit
02400
02500 ;! Local definitions ;!
02600
02700 inf==XWAC1
02800 outf==XWAC2
02900 numbered==outf+1
03000 icount==numbered+1
03100 xob==XBH+1
03200 ocount==xob+1
03300 lastword==ocount+1
03400 cnt==OFFSET(ZBHCNT)
03500 bup==OFFSET(ZBHBUP)
03600
03700 pgcopy: PROC
03800 LF XBH,ZFIIBH(inf) ;! Buffer header address
03900 SUBI XBH,1 ;! for input file
04000 L icount,cnt(XBH)
04100 IF ;! outf =/= NONE
04200 CAIN outf,NONE
04300 GOTO FALSE
04400 THEN ;! Get buffer header address, signal real output
04500 LF xob,ZFIOBH(outf)
04600 SUBI xob,1
04700 L ocount,cnt(xob)
04800 IF ;! First put after Outimage, but not first output
04900 L OFFSET(ZFIPGT)(outf)
05000 IFONA ZFIPGT
05100 GOTO FALSE
05200 IFOFFA ZFILBO
05300 IFONA ZFIFO
05400 GOTO FALSE
05500 THEN ;! Insert line feed
05600 SETOFA ZFIFO
05700 ST OFFSET(ZFIPGT)(outf)
05800 WHILE SOJGE ocount, FALSE
05900 DO XEC newoutbuf
06000 OD
06100 LI QLF
06200 IDPB bup(xob)
06300 FI
06400 SETON ZFILBO(outf) ;! So that Outimage does not
06500 ;! add LF next time
06600 ELSE ;! No output, zero xob, ocount
06700 SETZB xob,ocount
06800 FI
06900 IF ;! Not line numbered
07000 JUMPN numbered,FALSE
07100 THEN ;! Copy character by character
07200 LOOP
07300 WHILE SOJGE icount,FALSE
07400 DO ;! New buffer needed
07500 XEC newinbuff
07600 GOTO L9 ;! EOF
07700 OD
07800 ILDB bup(XBH) ;! Next character
07900 WHILE SOJGE ocount,FALSE
08000 DO
08100 JUMPE xob,L3
08200 XEC newoutbuf ;! Get a new output buffer
08300 OD
08400 IDPB bup(xob)
08500 L3():! AS
08600 CAIE QFF
08700 GOTO TRUE
08800 SA
08900 ELSE ;! Line numbered, handle full words
09000 SETZ lastword,
09100 L X1, bup(XBH)
09200 LOOP
09300 TLNN X1,300000
09400 GOTO FALSE
09500 IBP X1
09600 AS
09700 SOJA icount,TRUE
09800 SA
09900 IF ;! NOT normalized
10000 TLNE X1, (1B0)
10100 GOTO FALSE
10200 THEN ;! Normalize
10300 HRLI X1,(POINT 7,)
10400 ADDI X1,1
10500 FI
10600 ST X1, bup(XBH)
10700 L X1, bup(xob)
10800 LOOP
10900 TLNN X1,300000
11000 GOTO FALSE
11100 IBP X1
11200 AS
11300 SOJA ocount,TRUE
11400 SA
11500 IF ;! NOT normalized
11600 TLNE X1, (1B0)
11700 GOTO FALSE
11800 THEN ;! Normalize
11900 HRLI X1,(POINT 7,)
12000 ADDI X1,1
12100 FI
12200 ST X1, bup(xob)
12300 LOOP
12400 WHILE ;! Buffer empty
12500 SUBI icount, 5
12600 JUMPGE icount,FALSE
12700 DO ;! Get a new input buffer
12800 XEC newinbuff
12900 GOTO L8
13000 OD
13100 AOS X1, bup(XBH) ;! Next word address
13200 L -1(X1) ;! Current word
13300 WHILE ;! Buffer has no more room
13400 SUBI ocount, 5
13500 JUMPGE ocount,FALSE
13600 DO ;! New output buffer needed
13700 JUMPE xob,L6 ;! No output
13800 XEC newoutbuf
13900 OD
14000 AOS X2,bup(xob) ;! Next output buffer wd
14100 ST -1(X2) ;! Copy from input
14200 JUMPE TRUE ;! Null words just copied
14300 L6():! EXCH lastword
14400 TRNN lastword,1
14500 GOTO TRUE
14600 CAMN pgmark
14700 GOTO L7
14800 JUMPE TRUE
14900 WHILE ;! Last char = Char(0)
15000 TRNE 377
15100 GOTO FALSE
15200 DO
15300 LSH -7
15400 OD
15500 TRC <QFF>B34 ;! Check for FF
15600 TRCN <QFF>B34
15700 GOTO L7 ;! Found FF
15800 AS
15900 GOTO TRUE
16000 SA
16100
16200 L7():! ;! FF found in last word - 1
16300 SOS bup(XBH)
16400 ADDI icount,5
16500 L8():!
16600 JUMPE xob,L10
16700 SOS bup(xob)
16800 ADDI ocount,5
16900 FI
17000 L9():! JUMPE xob,L10
17100 ST ocount,cnt(xob)
17200 L10():! ST icount,cnt(XBH)
17300 RET
17400 EPROC
17500
17600 newinbuff:! PROC ;! Read a new buffer
17700 SAVE <X0,XWAC3>
17800 n==2 ;! Stack depth
17900 ST icount,cnt(XBH)
18000 XEC IORB
18100 IF ;! End of file seen
18200 IFOFF ZFIEND(inf)
18300 GOTO FALSE
18400 THEN ;! Endfile:= TRUE
18500 SETON ZIFEND(inf)
18600 ELSE ;! Skip return
18700 AOS -n(XPDP)
18800 L icount, cnt(XBH)
18900 PURGE n
19000 FI
19100 RETURN
19200 EPROC
19300
19400 newoutbuf:! PROC ;! Get a new output buffer
19500 SAVE <XBH,XWAC1,XWAC3>
19600 ST ocount,cnt(xob)
19700 L XBH,xob
19800 L XWAC1,outf
19900 SKIPG cnt(XBH)
20000 XEC IONB
20100 L ocount, cnt(XBH)
20200 RETURN
20300 EPROC
20400
20500 pgmark:! BYTE (7)QCR,QFF ;! SOS page mark
20600
20700 LIT
20800 END;