Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-05 - 43,50337/23/filest.mac
There are 2 other files named filest.mac in the archive. Click here to see a list.
00100	COMMENT * SIMULA specification;
00200	OPTIONS(/E:QUICK,ZYLILL);
00300	PROCEDURE illegal;
00400	COMMENT Dummy procedure, should not be called from SIMULA.
00500	;
00600	
00700	!*;! MACRO-10 code !*;!
00800	
00900		SUBTTL	FILEST, File definition string
01000	
01100	;!*** Copyright 1977 by the Swedish Defence Research Institute. ***
01200	;!*** Copying is allowed.					***
01300	
01400	Comment \
01500	
01600	Purpose:To form a string from a file lookup/enter block
01700	Input:	If X2 is a lookup blk ptr, X0 has sixbit device name.
01800		X1: Destination designator for specification string -
01900		    either byte pointer or address of subroutine for
02000		    handling one character.
02100		X2: File designator - either REF(file) or pointer to
02200		    LOOKUP/ENTER block (may be extended format)
02300		X3: Zero or format control flags (see below)
02400		X4: XWD -n,pointer to work area of n words (for PATH. blk etc)
02500	
02600	Output:	File specification, one character at a time, in X1.
02700		Each byte is transmitted to the destination via a
02800		subroutine pointed to by XOB in this procedure.
02900		The string format is:
03000		  dev:file.ext[path]<prot> (TOPS-10)
03100		  str:<directory>file.ext.,Pnnnnnn (TOPS-20)
03200		Protection is only output on demand.
03300		Null fields are not output.
03400	\
03500	
03600		TITLE	filest, file to string translation
03700		SUBTTL	SIMULA utility, Lars Enderin FOA June 1977
03800	
03900		SEARCH	UUOSYM,SIMMAC,SIMMCR,SIMRPA
04000		SALL
04100		MACINIT
04200	
04300		ENTRY	.FILST
04400	
04500	XOB==X5	;!Contains instruction to handle one byte in X1.
04600	P==XPDP	;!Push-down pointer
04700	
04800	OPDEF	OUTOCT		[XEC	.OUTOC]
04900	OPDEF	SIXASC		[XEC	.SIXAS]
05000	OPDEF	FILEST		[XEC	.FILST]
05100	OPDEF	OUTBYTE		[XCT	XOB]
05200	OPDEF	OUTPPN		[XEC	.OUTPP]
05300	
05400	DEFINE	OUTC(C)<
05500		LI	X1,C
05600		OUTBYTE>
05700	
05800	DEFINE DELIM(C)<
05900		LI	X1,C
06000		TRNE	X7,1
06100		OUTBYTE>
06200	
06300	;!Format control bits in X3 (X7):
06400	;!-------------------------
06500	
06600		RADIX	10
06700	
06800	DEFINE Z(F,M,N)<DF ZJS'F,0,M,N>
06900	DEFINE X(F)<
07000	IRP F,<
07100	N==N+3
07200	 Z F,3,\N
07300	>>
07400	DEFINE Y(F)<
07500	IRP F,<N==N+1
07600	 Z F,1,\N
07700	>>
07800	
07900	DEFINE OUTCHK(f,def)<
08000		STACK	def
08100		LF	X1,ZJS'f(,X7)
08200		XEC	.OUTCK
08300		UNSTK	(P)
08400	>
08500	
08600	N==-1
08700	X<DEV,DIR,NAM,TYP,GEN,PRO,ACT>
08800	N==20
08900	Y<TMP,SIZ,CRD,LWR,LRD>
09000	N==31
09100	Y<PSD,TBR,TBP,PAF>
09200		RADIX	8
09300	.JSNOF==0
09400	.JSAOF==1
09500	.JSSSD==2
     
09600	.FILST:	PROC
09700		SAVE	<X0,X1,X2,X3,X4,X5,X6,X7>
09800		N==1+7
09900		N0==1
10000		N1==N0+1	;!X1 offset from -N(P)
10100		LOWADR
10200		q==2B<%ZJSDEV>+2B<%ZJSDIR>+1B<%ZJSNAM>+1B<%ZJSTYP>+1B<%ZJSGEN>
10300		q==q+1B<%ZJSTMP>+1B<%ZJSPAF>
10400		SKIPN	X7,X3
10500		L	X7,[Q]	;!Default
10600	TOPS10,<
10700		IF	;! There is a work area supplied
10800			JUMPE	X4,FALSE
10900		THEN	;! Set up path block
11000			HLRZ	X1,X4
11100			SETZM	(X4)
11200			Q==1+11
11300			IF	;! Big enough
11400				CAIGE	X1,Q
11500				GOTO	FALSE
11600			THEN	;! Set it up
11700				HRLI	(X4)
11800				HRRI	1(X4)
11900				BLT	Q-1(X4)
12000				MOVSI	Q
12100				HRRI	Q(X4)
12200				ST	(X4)
12300				SUBI	X1,Q
12400				HRLZM	X1,1(X4)
12500		FI	FI
12600	>
12700	L1():!	L	X6,X1+N0-N(P)
12800		IF	;!X1 was a string ptr
12900			TLNN	X6,-1
13000			GOTO	FALSE
13100		THEN
13200			L	XOB,[IDPB X1,X6]
13300		ELSE	;!Should be routine address
13400			LI	XOB,(X6)
13500			HRLI	XOB,(XEC)
13600		FI
13700		IF	;!X2 could be a file ref
13800			LF	X1,ZDNTYP(X2)
13900			CAIE	X1,QZCL
14000			GOTO	FALSE
14100		THEN	;!Check for file prototype
14200			LF	X1,ZBIZPR(X2)
14300			LF	X1,ZCPGCI(X1)
14400			CAIE	X1,QIOFI
14500			 GOTO	 L9
14600			LF	,ZFIDVN(X2)	;!Device
14700			ST	N0-N(P)
14800			SKIPL	OFFSET(ZFICHN)(X2) ;! If channel assigned,
14900			 LF	,ZFICHN(X2)	;!Use it rather than device
15000			LF	X1,ZFIFIL(X2)
15100			IF	;!Pointer to extended lookup/enter blk
15200				TLNE	X1,-1
15300				GOTO	FALSE
15400			THEN	;!Make X2 point to file name there, flag this
15500				HRROI	X2,4(X1)
15600			ELSE	;!Point to ZFIFIL
15700				ADDI	X2,OFFSET(ZFIFIL)
15800			FI
15900		ELSE	;!Adjust pointer if extended lookup block
16000			L	X1,(X2)
16100			TLNN	X1,-1
16200			 HRROI	X2,.RBNAM(X2) ;! [-1,,filename]
16300			L	N0-N(P)		;! Device
16400		FI
     
16500		STACK	X2
16600		N==N+1
16700	TOPS10,<
16800		IF	;!There is a work area
16900			SKIPE	X4,X4+N0-N(P)
17000			SKIPN	(X4)
17100			GOTO	FALSE
17200		THEN	;!Check for ersatz device
17300			LI	X1,1(X4)
17400			ST	(X1)
17500			HRLI	X1,11
17600			IF	;!Ersatz
17700				PATH.	X1,
17800				 GOTO	FALSE
17900				L	X3,.PTSWT(X1)
18000				TRNN	X3,PT.IPP
18100				 GOTO	FALSE
18200			THEN	;!No SFD please
18300				SETZM	.PTPPN+1(X1)
18400				L	(X1)	;!Device again
18500			FI
18600			TLNN	-1
18700			 L	(X1)	;! The best value we have for device
18800		FI
18900		TLNN	-1
19000		 L	N0-N(P)		;!Use device name as given
19100		IF	;!Output of DEV: is requested
19200			OUTCHK	DEV,<['DSK   ']>
19300			JUMPE	X1,FALSE
19400		THEN	;!DEV:
19500			IF	;!Extended lookup block
19600				JUMPGE	X2,FALSE
19700			THEN	;!Find logical device name, then file structure
19800				L	X1,.RBDEV-.RBNAM(X2)
19900				JUMPE	X1,FALSE
20000				ST	X1,5(P)	;!Use stack for arguments
20100				LI	X1,5(P) ;! to DSKCHR
20200				HRLI	X1,.DCSNM+1 ;! Size of arg blk
20300				DSKCHR	X1,
20400				 GOTO	 FALSE	;!No luck
20500				L	.DCSNM+5(P)	;!File structure name
20600			ELSE	;!Get device name
20700				L	N0-N(P)
20800				DEVNAM
20900				 CAI
21000			FI
21100			LF X1,ZJSDEV(,X7)	;!Control field for DEV:
21200			IF	;! Conditional output
21300				CAIE X1,.JSSSD
21400				GOTO FALSE
21500			THEN	;!Check search list against device name
21600				LI X1,5(P) ;! Use stack for UUO args
21700				SETOM (X1) ;! Get first file struct
21800				HRLI X1,3
21900				JOBSTR X1,
22000				 GOTO FALSE
22100				CAMN (X1)
22200			ELSE	;! Output "DEV:"
22300				SIXASCII
22400				DELIM	":"
22500			FI
22600		FI
22700	>;!TOPS10
22800	TOPS20,<
22900		;!Output dev: or dev:<directory>
23000		L	X1,3(X2)
23100		SKIPG	X2
23200		L	X1,-1(X2)
23300		IF	;!No ppn
23400			JUMPN	X1,FALSE
23500		THEN	;!Just output dev: as is
23600			IF
23700				OUTCHK	DEV,<['DSK']>
23800				JUMPE	X1,FALSE
23900			THEN
24000				SIXASCII
24100				DELIM	":"
24200			FI
24300		ELSE	;!Construct dev:<directory>
24400			L	X2,X1
24500			STACK	XOB
24600			LI	XOB,[IDPB	X4
24700				     RET]
24800			HRLI	XOB,(XEC)
24900			L	X4,[POINT	7,5(P)]
25000			SIXASCII
25100			OUTC	0
25200			HRROI	X1,YOCTXT(XLOW)	;!Destination string
25300			HRROI	X3,5(P)		;!DEV
25400			PPNST%
25500			 ERJMP	[UNSTK XOB
25600				 UNSTK X2
25700				 BRANCH L9()]
25800	
25900			SKIPA	X3,[POINT 7,YOCTXT(XLOW)]
26000			LOOP
26100				OUTBYTE
26200				ILDB	X1,X3
26300			AS
26400				JUMPN	X1,TRUE
26500			SA
26600		FI
26700		UNSTK	XOB
26800	>;!TOPS20
26900		UNSTK	X2
27000		N==N-1
     
27100		IF	;!Filename wanted
27200			TLNN	X7,(7B<%ZJSNAM>)
27300			GOTO	FALSE
27400		THEN	;!Output it
27500			L	(X2)
27600			SIXASCII
27700			DELIM	"."
27800		FI
27900		IF	;!Extension wanted
28000			TLNN	X7,(7B<%ZJSTYP>)
28100			GOTO	FALSE
28200		THEN
28300			HLLZ	1(X2)
28400			SIXASCII
28500		FI
28600	TOPS10,<
28700		L	X3,3(X2)	;!PPN or SFD ptr
28800		SKIPG	X2
28900		L	X3,-1(X2)
29000		L	X1,X3
29100		IF	;!No defined path		CAME	X3,[-1]
29200	
29300			JUMPN	X3,FALSE
29400		THEN	;!Use device path
29500			IF	;!Path available
29600				SKIPE	X4,X4+N0-N(P)
29700				SKIPN	(X4)
29800				GOTO	FALSE
29900			THEN	;!Use it
30000				LI	X3,1(X4)
30100		FI	FI
30200		IF	;!Directory suppressed
30300			TLNE	X7,(7B<%ZJSDIR>)
30400			GOTO	FALSE
30500		THEN	SETZ	X3,
30600		ELSE
30700			IF	;!Not always output
30800				TLNE	X7,(<.JSAOF>B<%ZJSDIR>)
30900				GOTO	FALSE
31000			THEN	;!Check for default path
31100				IF	;!Path space available
31200					SKIPE	X4,X4+N0-N(P)
31300					SKIPN	X1,(X4)
31400					GOTO	FALSE
31500				THEN
31600					HLRZ	X1
31700					IF	;!Big enough
31800						CAIGE	11
31900						GOTO	FALSE
32000					THEN	;!Get default path
32100						LI	X1,1(X1)
32200						HRLI	X1,11
32300						SETOM	(X1)
32400						IF	;!Path is found
32500							PATH.	X1,
32600							GOTO	 FALSE
32700						THEN
32800							IF	;!PPN only
32900								TLNN	X3,-1
33000								GOTO	FALSE
33100							THEN	;!Check ppn+first SFD
33200								SKIPN	.PTPPN+1(X1)
33300								CAME	X3,.PTPPN(X1)
33400								GOTO	L7 ;!Unequal
33500								GOTO	L6 ;!Equal
33600							FI
33700							LI	X4,(X3)
33800							HLRZ	(X4)
33900							CAIN	QZYS
34000							ADDI	X4,2
34100							HRLI	X1,-6
34200							LOOP
34300								L	.PTPPN(X1)
34400								CAME	.PTPPN(X4)
34500								GOTO	FALSE
34600								JUMPE	L6
34700							AS
34800								ADDI	X4,1
34900								AOBJN	X1,TRUE
35000					L6():!			SETZB	X1,X3
35100							SA
35200				L7():!
35300		FI	FI	FI	FI	FI
35400		IF	;!Path not suppressed
35500			JUMPE	X3,FALSE
35600		THEN	;!Output [path]
35700			DELIM	"["
35800			IF	;!Not SFD
35900				TLNN	X3,-1
36000				GOTO	FALSE
36100			THEN	;!Just p,pn
36200				L	X3
36300				OUTPPN
36400			ELSE	;!Full path with SFD's
36500				HLRZ	(X3)		;!If not a ZYS blk ptr,
36600				CAIE	QZYS
36700				SUBI	X3,2		;!Fake overhead
36800				L	4(X3)
36900				OUTPPN
37000				LOOP
37100					L	5(X3)
37200					JUMPE	FALSE
37300					OUTC	<",">
37400					SIXASCII
37500				AS
37600					AOJA	X3,TRUE
37700				SA
37800			FI
37900			DELIM	"]"
38000		FI
38100	>;!TOPS10
38200		L	X1,[12,,16]
38300		GETTAB	X1,			;!Default prot
38400		 MOVSI	 X1,(055B8)		;!Assume 055 on failure
38500		ROT	X1,9
38600		LDB	[POINT 9,2(X2),8]
38700		IF	;!Protection should be output
38800			JUMPE FALSE
38900			OUTCHK	PRO,X1
39000			JUMPE	X1,FALSE
39100		THEN	;!Output prot
39200			TOPS10,<
39300			DELIM	"<"
39400			OUTOCT
39500			DELIM	">"
39600			>;!TOPS10
39700			TOPS20,<
39800			DELIM	";!"
39900			DELIM	"P"
40000			SETZ	X1,
40100			LOOP
40200				LI	X2,7
40300				AND	X2,X0
40400				OR	X1,[EXP 77,77,66,56,56,52,12,02](X2)
40500				ROT	X1,-6
40600				LSH	X0,-3
40700			AS
40800				TLNN	X1,77
40900				GOTO	TRUE
41000			SA
41100			HLRZ	X1
41200			IF
41300				OUTCHK	PRO,<[775200]>	;!??
41400				JUMPE	X1,FALSE
41500			THEN
41600				STACK
41700				LSH	-9
41800				OUTOCT
41900				UNSTK
42000				OUTOCT
42100			FI
42200			>;!TOPS20
42300		FI
42400	L9():!	RETURN
42500		EPROC
     
42600		SUBTTL	OUTOCT
42700	
42800	;!Input:	X0 9-bit number
42900	;!	XOB bytehandler instruction (OUTBYTE)
43000	;!Output:ASCII octal digits via X1 to bytehandler
43100	
43200	.OUTOC:	IF	;! Non-zero
43300			JUMPE	FALSE
43400		THEN
43500			HRLO
43600			LSH	9
43700			LOOP
43800				LI	X1,"0"_-3
43900				ROTC	3
44000				OUTBYTE
44100			AS
44200				TRNE	-1	;!All digits exhausted
44300				GOTO	TRUE
44400			SA
44500		FI
44600		RET
     
44700		SUBTTL	OUTPPN
44800	
44900	;!Input:	X0=ppn
45000	;!Output:nnnnnn,nnnnnn (octal digits) via outbyte
45100	
45200	.OUTPP:	PROC
45300		SAVE	X0
45400		N==1
45500		HLRZ	1-N(P)
45600		XEC	.OUTP
45700		OUTC	<",">
45800		HRRZ	1-N(P)
45900		XEC	.OUTP
46000		RETURN
46100		EPROC
46200	
46300	
46400	.OUTP:	;!Octal number in ascii with zero suppression
46500		IF	;!ZERO
46600			JUMPN	FALSE
46700		THEN	;!Just one 0 output
46800			OUTC	"0"
46900		ELSE	;!Suppress initial zeros
47000			HRLO	;!Flag in right half
47100			WHILE
47200				TLNE	(7B2)
47300				GOTO	FALSE
47400			DO
47500				LSH	3
47600			OD
47700			LOOP
47800				LI	X1,"0"_-3
47900				ROTC	3
48000				OUTBYTE
48100			AS
48200				TRNE	-1
48300				GOTO	TRUE
48400			SA
48500		FI
48600		RET
     
48700		SUBTTL	OUTCHK
48800	
48900	;!Check if field should be output: X1=value of control field, X0 is current
49000	;!value of field, defaultfield is default value.
49100	;!X1 = 0 if no output should be done.
49200	;!Field value in X0 on return.
49300	
49400	.OUTCK:	PROC	defaultfield
49500		CAIN	X1,.JSNOF
49600		 GOTO	L9
49700		SKIPN
49800		 L	defaultfield
49900		CAIE	X1,.JSAOF
50000		 CAME	defaultfield
50100		  SKIPA	X1,[-1]
50200	L9():!	   SETZ	X1,
50300		RET
50400		EPROC
     
50500		SUBTTL	SIXASC
50600	
50700	;!Input:	SIXBIT word in X0.
50800	;!Output:ASCII  characters in X1, to outbyte
50900	
51000	.SIXAS::IF	;! Non-zero
51100			JUMPE	FALSE
51200		THEN
51300			LOOP
51400				SETZ	X1,
51500				ROTC	6
51600				ADDI	X1," "
51700				OUTBYTE
51800			AS
51900				JUMPN	TRUE
52000			SA
52100		FI
52200		RET
     
52300		LIT
52400		END;