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