Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-04 - decus/20-0135/05/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;