Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/libsim/rename.mac
There are 4 other files named rename.mac in the archive. Click here to see a list.
00100 COMMENT * SIMULA specification;
00200 OPTIONS(/E:CODE,NOCHECK,ZYLRNM);
00300 INTEGER PROCEDURE rename;!(fs1,fs2,force);
00400 !NAME fs1,fs2,force;
00500 !BOOLEAN force;
00600 !TEXT or REF(FILE) fs1;
00700 !TEXT fs2;
00800 COMMENT fs1 is either a file specification text or a reference to a file object.
00900 fs2 is a (partial) file specification. Missing fields are taken from fs1.
01000 Information from fs2 is substituted in fs1 and a RENAME UUO is executed.
01100 If fs2==NOTEXT, the file defined by fs1 is deleted.
01200 If force==TRUE, a RENAME changing only the protection is tried first, then
01300 a full RENAME.
01400 The result is -1 if RENAME worked, error code if not.
01500 Common error codes:
01600 ERFNF% 0 File not found (refers to first file)
01700 ERIPP% 1 Illegal path (ppn or full sfd path)
01800 ERPRT% 2 Protection failure
01900 ERAEF% 4 Already existing filename
02000
02100 Other error codes are listed in the DECsystem-10 Monitor Calls manual.
02200 ;
02300
02400 !*;! MACRO-10 code !*;!
02500
02600 TITLE rename
02700 ENTRY ZYLRNM
02800 SUBTTL SIMULA utility, Lars Enderin Sept 1977
02900
03000 ;!* Copyright 1977 by the Swedish Defence Research Institute. *
03100 ;!* Copying is allowed. *
03200
03300
03400 sall
03500 search simmac,simmcr,simrpa
03600 macinit
03700
03800 ;! Special error codes:
03900
04000 notdsk==1000
04100 reoper==1001 ;! Could not reopen fs1
04200 fs2err==1002 ;! Error in fs2
04300 deverr==1003 ;! Cannot change device
04400
04500 ;! Local definitions ;!
04600
04700 DEFINE error(code,label,op)
04800 < HRREI code
04900 IFNB <label>,<IFNB <op>,<op label>
05000 IFB <op>,<JSP XFP,label>>
05100 >
05200 DEFINE erret(c,l)<JSP XFP,[error(c,l,GOTO)]>
05300 DEFINE eval(x)
05400 < LI XWAC1,(XCB)
05500 HRLI XWAC1,x
05600 XEC PHFV
05700 Z
05800 >
05900 DEFINE normaltext
06000 < IF TLNN XWAC1,-1
06100 GOTO FALSE
06200 THEN XEC TXCY
06300 Z
06400 FI
06500 >
06600
06700 rbmax==.RBSIZ
06800 pthsav==rbmax+1
06900 rnsz==3+pthsav
07000 result==2
07100 fs1==result+1
07200 fs2==fs1+2
07300 force==fs2+2
07400
07500 OPDEF readjust [XEC renrea]
07600 OPDEF LOKUP [XEC .LOKUP]
07700 OPDEF RENAM [XEC .RENAM]
07800 IFN <%ZFIOP>,<PRINTX %ZFIOPN not bit zero as assumed>
07900 OPDEF IFOPEN [SKIPGE OFFSET(ZFIOPN)]
08000 OPDEF IFNOTOPEN [SKIPL OFFSET(ZFIOPN)]
08100 ZYLRNM: PROC
08200 eval(fs1)
08300 LF ,ZFLATP(XCB,fs1)
08400 IF ;! TEXT
08500 CAIE QTEXT
08600 GOTO FALSE
08700 THEN ;! Ok, save text pointer
08800 STD XWAC1,fs1(XCB)
08900 ELSE ;! Must be REF(FILE)
09000 CAIE QREF
09100 RTSERR 107 ;! Wrong type
09200 ST XWAC1,fs1(XCB)
09300 LI -1 ;! allow subclass
09400 LI XSAC,IOFI
09500 XEC CSQU ;! Check for file subclass
09600 SKIPN XWAC1
09700 RTSERR 111 ;! Wrong qualification
09800 SETZM fs1+1(XCB)
09900 FI
10000
10100 IF ;! Second parameter exists
10200 SKIPN fs2(XCB)
10300 GOTO FALSE
10400 THEN ;! It must be a text
10500 LF ,ZFLATP(XCB,fs2)
10600 CAIE QTEXT
10700 RTSERR 107 ;! Wrong type
10800 eval(fs2)
10900 normaltext
11000 STD XWAC1,fs2(XCB) ;! Save text pointer
11100 FI
11200 RNMFS1:
11300 LD XWAC1,fs1(XCB)
11400 IF ;! fs1 was a text
11500 JUMPE XWAC2,FALSE
11600 THEN ;! Create a file object
11700 normaltext
11800 STD XWAC1,fs1(XCB)
11900 XEC CPNE
12000 XWD 0,IOIN
12100 LD XWAC2,fs1(XCB)
12200 STD XWAC2,OFFSET(ZFISPC)(XWAC1)
12300 LI 1B<%ZFIFND>+1B<%ZFIBNW>
12400 ST OFFSET(ZFIFND)(XWAC1)
12500 XEC CSEN
12600 IFOFF ZIFEND(XWAC1)
12700 BRANCH CSEP ;! fs1 not found
12800 ST XWAC1,fs1(XCB)
12900 FI
13000 LF ,ZFIKAR(XWAC1)
13100 TLNN DV.DIR
13200 erret(-1,fs1cl3) ;! Ok return if RENAME is meaningless anyway
13300
13400 TLNN DV.DSK
13500 erret(notdsk,fs1cl3)
13600
13700 LF X2,ZFICHN(XWAC1)
13800 HLL X2,OFFSET(ZFICHN)(XWAC1)
13900 IFOPEN(XWAC1)
14000 XEC IOCL
14100 LOWADR
14200 ADDI X2,YIOCHT(XLOW)
14300 LF X1,ZFIFIL(XWAC1)
14400 LI X1,OFFSET(ZXBARG)(X1)
14500 L .RBDEV(X1)
14600 SF ,ZFIDVN(XWAC1)
14700 L X2
14800 TLO (OPEN)
14900 HRRI OFFSET(ZFISTI)(XWAC1)
15000 XCT ;! OPEN the channel again
15100 erret(reoper,fs1cl3)
15200 edit(310)
15300 L OFFSET(ZFIFND)(XWAC1) ;! [310]
15400 IFOFFA ZFIDF ;! Claim channel again, by storing
15500 IFONA ZFIIF ;! file obj addr in right half of
15600 ST XWAC1,(X2) ;! channel table entry for directfiles
15700 IFOFFA ZFIIF ;! and infiles, in left half for
15800 HRLM XWAC1,(X2) ;! outfiles (and also directfiles)
15900 ;! [310] end
16000 HLLM X2,OFFSET(ZFICHN)(XWAC1)
16100 L XWAC3,.RBPPN(X1) ;! Path
16200 IF ;! SFD ptr
16300 JUMPE XWAC3,FALSE
16400 TLNE XWAC3,-1
16500 GOTO FALSE
16600 THEN ;! Adjust pointer
16700 LI 2
16800 ADDM .RBPPN(X1)
16900 FI
17000 LI X2,(X1)
17100 LOKUP
17200 GOTO [SETON ZFIOPN(XWAC1)
17300 erret(reoper,fs1cl)]
17400
17500 ;! Open again
17600 SETZB XWAC2,XWAC3 ;! Need no image
17700 SETON ZFIBNW(XWAC1) ;! and no buffers
17800 edit(310)
17900 SETZM OFFSET(ZFIOBH)(XWAC1) ;! [310]
18000 XEC IOOP
18100 SETOFF ZFIBNW(XWAC1)
18200 RNMFS2:
18300 L XWAC2,fs2+1(XCB)
18400 IF ;! fs2 was a non-empty text
18500 JUMPE XWAC2,FALSE
18600 THEN ;! Create file object, no lookup, no buffer, no error msg
18700 XEC CPNE
18800 Z IOIN
18900 LD XWAC2,fs2(XCB)
19000 STD XWAC2,OFFSET(ZFISPC)(XWAC1)
19100 LI 1B<%ZFIFND>+1B<%ZFIBNW>+1B<%ZFINLE>
19200 ST OFFSET(ZFIBNW)(XWAC1)
19300 XEC CSEN
19400 L X2,OFFSET(ZIFEND)(XWAC1) ;! Zero on error
19500 HLLZ X1,OFFSET(ZFICHN)(XWAC1)
19600 IF ;! Non-zero channel
19700 JUMPE X1,FALSE
19800 THEN ;! RELEASE
19900 TLO X1,(RELEASE)
20000 XCT X1
20100 LOWADR
20200 edit(310)
20300 LF X1,ZFICHN(XWAC1) ;![310]
20400 ADDI X1,YIOCHT(XLOW)
20500 SETZM (X1)
20600 FI
20700 JUMPE X2,[error(fs2err,fs1cl)]
20800 ST XWAC1,fs2(XCB)
20900 SETZM 1+fs2(XCB)
21000 IF ;! DEV not good enough
21100 WLF ,ZFIKAR(XWAC1)
21200 TLNN DV.DSK
21300 GOTO TRUE
21400 LF ,ZFIDVN(XWAC1)
21500 DEVNAM
21600 GOTO TRUE
21700 L X1,fs1(XCB)
21800 LF X1,ZFIDVN(X1)
21900 XOR X1,
22000 JUMPE X1,FALSE
22100 LSHC 6
22200 TLNN X1,770000
22300 JUMPN X1,.-2
22400 JUMPE FALSE
22500 THEN ;! Error
22600 erret(deverr,fs1cl)
22700 FI FI
22800
22900 RNMBLK: IF ;! force given
23000 SKIPN force(XCB)
23100 GOTO FALSE
23200 THEN eval(force)
23300 SETZM force(XCB)
23400 HLLZM XWAC1,1+force(XCB) ;! Save value as halfword
23500 FI
23600
23700
23800 ;! Allocate a block for RENAME info
23900 L XTAC,[QZXB,,rnsz+13]
24000 XEC SAAR
24100 LI XWAC5,OFFSET(ZXBARG)(XTAC)
24200 LI rbmax
24300 ST .RBCNT(XWAC5)
24400 LI XWAC6,2+rnsz(XTAC)
24500 MOVSI QZYS
24600 ST -2(XWAC6)
24700 LI 13
24800 ST -1(XWAC6)
24900
25000 L XWAC1,fs1(XCB)
25100 LF X1,ZFIFIL(XWAC1)
25200 ADDI X1,OFFSET(ZXBARG)
25300
25400 LD XWAC2,fs2(XCB)
25500 IF ;! Delete implied
25600 JUMPN XWAC2,FALSE
25700 THEN ;! Zero filename etc
25800 LI X2,(XWAC5) ;! RENAME info
25900 STD XWAC2,.RBPPN(X2)
26000 STD XWAC2,.RBEXT(X2)
26100 ELSE ;! RENAME info from fs2
26200 LF X2,ZFIFIL(XWAC2)
26300 ADDI X2,OFFSET(ZXBARG)
26400 ;! Build RENAME info
26500 SKIPN XWAC3,.RBNAM(X2)
26600 L XWAC3,.RBNAM(X1) ;! File name
26700 ST XWAC3,.RBNAM(XWAC5)
26800 SKIPN XWAC3,.RBEXT(X2) ;! EXT
26900 L XWAC3,.RBEXT(X1)
27000 HLLZM XWAC3,.RBEXT(XWAC5)
27100 SKIPN XWAC3,.RBPRV(X2)
27200 L XWAC3,.RBPRV(X1) ;! PROT
27300 TLZ XWAC3,777
27400 HLLZM XWAC3,.RBPRV(XWAC5)
27500 L XWAC3,.RBPPN(X2)
27600 ;! Old path to XWAC4
27700 L XWAC4,.RBPPN(X1)
27800 IF ;! Path pointer
27900 JUMPE XWAC4,FALSE
28000 THEN ;! Adjust
28100 HLRZ (XWAC4)
28200 CAIN QZYS
28300 ADDI XWAC4,2
28400 FI
28500 IF ;! New path is zero
28600 JUMPN XWAC3,FALSE
28700 THEN ;! Use old path
28800 L XWAC3,XWAC4
28900 ELSE
29000 IF ;! Path block address
29100 TLNE XWAC3,-1
29200 GOTO FALSE
29300 THEN ;! Adjust for ZYS overhead
29400 HLRZ (XWAC3)
29500 CAIN QZYS
29600 ADDI XWAC3,2
29700 ELSE ;! Make sure new path is used
29800 IF ;! Old path not a ppn
29900 JUMPE XWAC4,FALSE
30000 TLNE XWAC4,-1
30100 GOTO FALSE
30200 THEN ;! Use old path, modified
30300 ST XWAC3,.PTPPN(XWAC6)
30400 L XWAC3,XWAC6
30500 FI FI FI
30600 ST XWAC3,.RBPPN(XWAC5)
30700 FI
30800 ST XWAC3,pthsav(XWAC5) ;! Save new path
30900 RNM: ;! Now try RENAME
31000 LI X2,(XWAC5)
31100 RENAM
31200 SKIPA
31300 GOTO L6 ;! OK?
31400
31500 HRRZ .RBEXT(XWAC5)
31600 IF ;! Protection error
31700 CAIE ERPRT%
31800 GOTO FALSE
31900 THEN ;! Quit unless force EQV TRUE
32000 SKIPN force+1(XCB)
32100 GOTO fs1cl
32200 HLRZ .RBEXT(XWAC5)
32300 CAIE 'UFD'
32400 CAIN 'SFD'
32500 GOTO fs1cl1
32600 FI
32700
32800 LI X2,(X1)
32900 LOKUP ;! Get fresh path info
33000 GOTO fs1cl1
33100
33200 ;! Try to change protection first
33300 STACK .RBPRV(X1)
33400 LI 100
33500 DPB [POINT 9,.RBPRV(X1),8]
33600 RENAM
33700 GOTO [UNSTK .RBPRV(X1)
33800 GOTO fs1cl1] ;! No luck
33900 UNSTK .RBPRV(X1)
34000 SETOFF ZFIOPN(XWAC1)
34100 SETON ZIFEND(XWAC1)
34200 ;! Reopen the channel
34300 LI OFFSET(ZFISTI)(XWAC1)
34400 HLL OFFSET(ZFICHN)(XWAC1)
34500 TLO (OPEN)
34600 XCT
34700 erret(ERPRT%,fs1cl)
34800 SETON ZFIOPN(XWAC1)
34900 ;! LOOKUP file again
35000 LOKUP
35100 GOTO fs1cl2
35200 LI X2,(XWAC5)
35300 L pthsav(XWAC5)
35400 ST .RBPPN(XWAC5)
35500 RENAM ;! Try again
35600 GOTO fs1cl2 ;! Tough luck
35700
35800 L6():! ;!Ok
35900 SETOM result(XCB)
36000 ;! Modify file lookup info to reflect rename
36100 L .RBNAM(XWAC5)
36200 ST .RBNAM(X1)
36300 L .RBEXT(XWAC5)
36400 HLLM .RBEXT(X1)
36500 LDB [POINT 9,.RBPRV(XWAC5),8]
36600 DPB [POINT 9,.RBPRV(X1),8]
36700 L XWAC3,pthsav(XWAC5)
36800 readjust
36900 ST XWAC3,.RBPPN(X1)
37000 BRANCH fs1cl4
37100
37200 fs1cl3: ST result(XCB)
37300 BRANCH fs1cl4
37400 fs1cl2: HRRZ .RBEXT(X2)
37500 ST result(XCB)
37600 HRRI X2,(X1) ;! Restore protection
37700 RENAM
37800 GOTO L8
37900 GOTO L8
38000 fs1cl1: HRRZ .RBEXT(X2) ;! Error code from rename/lookup
38100 fs1cl: ST result(XCB)
38200 L8():! readjust
38300 L XWAC1,fs1(XCB)
38400 LF X1,ZFIFIL(XWAC1)
38500 ST XWAC3,2+.RBPPN(X1)
38600 fs1cl4: IF ;! Not Open
38700 IFOPEN(XWAC1)
38800 GOTO FALSE
38900 THEN ;! Release channel and clear channel table entry
39000 HLLZ OFFSET(ZFICHN)(XWAC1)
39100 TLO (RELEASE)
39200 XCT
39300 LF X1,ZFICHN(XWAC1)
39400 ADDI X1,(XLOW)
39500 SETZM YIOCHT(X1)
39600 ELSE
39700 XEC IOCL
39800 FI
39900 BRANCH CSEP
40000 EPROC
40100
40200 renrea: IF ;! path address
40300 JUMPE XWAC3,FALSE
40400 TLNE XWAC3,-1
40500 GOTO FALSE
40600 THEN ;! Readjust
40700 HLRZ -2(XWAC3)
40800 CAIN QZYS
40900 SUBI XWAC3,2
41000 FI
41100 RET
41200
41300 BEGIN
41400 .RENAM: HLL X2,OFFSET(ZFICHN)(XWAC1)
41500 TLO X2,(RENAME)
41600 GOTO L2
41700
41800 .LOKUP: HLL X2,OFFSET(ZFICHN)(XWAC1)
41900 TLO X2,(LOOKUP)
42000 L2():! STACK .RBPPN(X2)
42100 XCT X2
42200 SKIPA
42300 AOS -1(XPDP)
42400 UNSTK .RBPPN(X2)
42500 RET
42600
42700 LIT
42800 END;