mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-26 18:04:07 +00:00
1285 lines
60 KiB
Plaintext
1285 lines
60 KiB
Plaintext
Compilation of: INITDIR
|
|
|
|
D: Disk Print
|
|
L: List Source Program
|
|
|
|
%include 'diomod.dcl';
|
|
%include 'initdira.dcl';
|
|
No Error(s) in Pass 1
|
|
|
|
No Error(s) in Pass 2
|
|
|
|
1 a 0000 initdir: procedure options(main);
|
|
2 c 0000
|
|
3 c 0000 /* REVISION HISTORY:
|
|
4 c 0000 1/24/83 whf converted to run on CCP/M-86
|
|
5 c 0000 11/12/82 pb fixed bug in clearout, buildnew, and reconstruction */
|
|
6 c 0000
|
|
7 c 0000 declare
|
|
8 c 0006 COPYRIGHT char(44) static initial
|
|
9 c 0006 ('COPYRIGHT (c) 1983 BY DIGITAL RESEARCH INC.');
|
|
10 c 0006
|
|
11 c 0006 /*
|
|
12 c 0006 copyright(c) 1982, 1983
|
|
13 c 0006 digital research
|
|
14 c 0006 box 579
|
|
15 c 0006 pacific grove, ca
|
|
16 c 0006 93950
|
|
17 c 0006 */
|
|
18 c 0006
|
|
19 c 0006 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
20 c 0006
|
|
21 c 0006
|
|
22 c 0006 * * * DISK INTERFACE * * *
|
|
23 c 0006
|
|
24 c 0006
|
|
25 c 0006 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
|
26 c 0006
|
|
27+c 0006
|
|
28+c 0006 dcl
|
|
29+c 0006 memptr entry returns (ptr),
|
|
30+c 0006 memsiz entry returns (fixed(15)),
|
|
31+c 0006 memwds entry returns (fixed(15)),
|
|
32+c 0006 dfcb0 entry returns (ptr),
|
|
33+c 0006 dfcb1 entry returns (ptr),
|
|
34+c 0006 dbuff entry returns (ptr),
|
|
35+c 0006 reboot entry,
|
|
36+c 0006 rdcon entry returns (char(1)),
|
|
37+c 0006 wrcon entry (char(1)),
|
|
38+c 0006 rdrdr entry returns (char(1)),
|
|
39+c 0006 wrpun entry (char(1)),
|
|
40+c 0006 wrlst entry (char(1)),
|
|
41+c 0006 coninp entry returns (char(1)),
|
|
42+c 0006 conout entry (char(1)),
|
|
43+c 0006 rdstat entry returns (bit(1)),
|
|
44+c 0006 getio entry returns (bit(8)),
|
|
45+c 0006 setio entry (bit(8)),
|
|
46+c 0006 wrstr entry (ptr),
|
|
47+c 0006 rdbuf entry (ptr),
|
|
48+c 0006 break entry returns (bit(1)),
|
|
49+c 0006 vers entry returns (bit(16)),
|
|
50+c 0006 reset entry,
|
|
51+c 0006 select entry (fixed(7)) returns (bit(16)),
|
|
52+c 0006 open entry (ptr) returns (bit(16)),
|
|
53+c 0006 close entry (ptr) returns (bit(16)),
|
|
54+c 0006 sear entry (ptr) returns (bit(16)),
|
|
55+c 0006 searn entry returns (bit(16)),
|
|
56+c 0006 delete entry (ptr) returns (bit(16)),
|
|
57+c 0006 rdseq entry (ptr) returns (bit(16)),
|
|
58+c 0006 wrseq entry (ptr) returns (bit(16)),
|
|
59+c 0006 make entry (ptr) returns (bit(16)),
|
|
60+c 0006 rename entry (ptr) returns (bit(16)),
|
|
61+c 0006 logvec entry returns (bit(16)),
|
|
62+c 0006 curdsk entry returns (fixed(7)),
|
|
63+c 0006 setdma entry (ptr),
|
|
64+c 0006 allvec entry returns (ptr),
|
|
65+c 0006 wpdisk entry,
|
|
66+c 0006 rovec entry returns (bit(16)),
|
|
67+c 0006 filatt entry (ptr),
|
|
68+c 0006 getdpb entry returns (ptr),
|
|
69+c 0006 getusr entry returns (fixed(7)),
|
|
70+c 0006 setusr entry (fixed(7)),
|
|
71+c 0006 rdran entry (ptr) returns (bit(16)),
|
|
72+c 0006 wrran entry (ptr) returns (bit(16)),
|
|
73+c 0006 filsiz entry (ptr),
|
|
74+c 0006 setrec entry (ptr),
|
|
75+c 0006 resdrv entry (bit(16)) returns (bit(16)),
|
|
76+c 0006 wrranz entry (ptr) returns (bit(16));
|
|
77+c 0006 /**** commented out for CCP/M-86 whf
|
|
78+c 0006 dcl
|
|
79+c 0006 testwr entry (ptr) returns (bit(16)),
|
|
80+c 0006 lock entry (ptr) returns (fixed(7)),
|
|
81+c 0006 unlock entry (ptr) returns (fixed(7)),
|
|
82+c 0006 multis entry (fixed(7)) returns (fixed(7)),
|
|
83+c 0006 ermode entry (bit(1)),
|
|
84+c 0006 freesp entry (fixed(7)) returns (bit(16)),
|
|
85+c 0006 chain entry returns (bit(16)),
|
|
86+c 0006 flush entry returns (fixed(7)),
|
|
87+c 0006 setlbl entry (ptr) returns (bit(16)),
|
|
88+c 0006 getlbl entry (fixed(7)) returns (bit(8)),
|
|
89+c 0006 rdxfcb entry (ptr) returns (bit(16)),
|
|
90+c 0006 wrxfcb entry (ptr) returns (bit(16)),
|
|
91+c 0006 settod entry (ptr),
|
|
92+c 0006 gettod entry (ptr),
|
|
93+c 0006 dfpswd entry (ptr),
|
|
94+c 0006 sgscb entry (ptr) returns(bit(8));
|
|
95 c 0006 ****/
|
|
96 c 0006
|
|
97 c 0006
|
|
98+c 0006 declare
|
|
99+c 0006 seldsk entry (fixed(7)) returns(ptr),
|
|
100+c 0006 settrk entry (fixed(15)),
|
|
101+c 0006 setsec entry (fixed(15)),
|
|
102+c 0006 rdsec entry returns(fixed(7)),
|
|
103+c 0006 wrsec entry (fixed(7)) returns(fixed(7)),
|
|
104+c 0006 sectrn entry (fixed(15), ptr) returns(fixed(15)),
|
|
105+c 0006 bstdma entry (ptr);
|
|
106 c 0006
|
|
107+c 0006 declare /* CCPM special functions whf 1/14/82 */
|
|
108+c 0006 openvec entry returns(fixed(15)),
|
|
109+c 0006 syslock entry returns(fixed(7)),
|
|
110+c 0006 sysunlock entry,
|
|
111+c 0006 conlock entry returns(fixed(7)),
|
|
112+c 0006 conunlock entry;
|
|
113 c 0006
|
|
114 c 0006 %replace
|
|
115 c 0006 TRUE by '1'b,
|
|
116 c 0006 FALSE by '0'b;
|
|
117 c 0006
|
|
118 c 0006 /* directory array 4K */
|
|
119 c 0006 declare
|
|
120 c 0006 1 dir_fcb(0:127),
|
|
121 c 0006 3 user bit(8),
|
|
122 c 0006 3 rest(31) char(1),
|
|
123 c 0006
|
|
124 c 0006 1 outbuf(0:127),
|
|
125 c 0006 2 user fixed(7),
|
|
126 c 0006 2 rest(31) char(1),
|
|
127 c 0006
|
|
128 c 0006 1 buffer2(0:127),
|
|
129 c 0006 2 user bit(8),
|
|
130 c 0006 2 rest(31) bit(8),
|
|
131 c 0006
|
|
132 c 0006 1 outb(0:127) based(outptr),
|
|
133 c 0006 2 rest char(32),
|
|
134 c 0006
|
|
135 c 0006 1 outb2(0:127) based(outptr),
|
|
136 c 0006 2 user bit(8),
|
|
137 c 0006 2 rest(31) char(1),
|
|
138 c 0006
|
|
139 c 0006 1 outb3(0:127) based(outptr),
|
|
140 c 0006 2 user fixed(7),
|
|
141 c 0006 2 rest(31) bit(8),
|
|
142 c 0006
|
|
143 c 0006 1 outb4(0:127) based(outptr),
|
|
144 c 0006 2 sfcbm char(1),
|
|
145 c 0006 2 sfcb(3),
|
|
146 c 0006 3 stamps char(8),
|
|
147 c 0006 3 mode bit(8),
|
|
148 c 0006 3 rest char(1),
|
|
149 c 0006 2 frest char(1),
|
|
150 c 0006
|
|
151 c 0006 1 infcb(0:127) based(dirptr),
|
|
152 c 0006 2 rest char(32),
|
|
153 c 0006
|
|
154 c 0006 1 infcb2(0:127) based(dirptr),
|
|
155 c 0006 2 user char(1),
|
|
156 c 0006 2 name char(11),
|
|
157 c 0006 2 pmode bit(8),
|
|
158 c 0006 2 junk1 char(11),
|
|
159 c 0006 2 stamp char(8),
|
|
160 c 0006
|
|
161 c 0006 1 clearbuf(0:127) based(clearptr),
|
|
162 c 0006 2 rest char(32),
|
|
163 c 0006
|
|
164 c 0006 zeroes(31) bit(8) static init((31)'00000000'b)
|
|
165 c 0006 ;
|
|
166 c 0006
|
|
167 c 0006 /* directory array mask */
|
|
168 c 0006 declare
|
|
169 c 0006 1 dirm(0:127) based(dirptr),
|
|
170 c 0006 3 user fixed(7),
|
|
171 c 0006 3 fname char(8),
|
|
172 c 0006 3 ftype char(3),
|
|
173 c 0006 3 fext bin fixed(7),
|
|
174 c 0006 3 fs1 bit(8),
|
|
175 c 0006 3 fs2 bit(8),
|
|
176 c 0006 3 frc fixed(7),
|
|
177 c 0006 3 diskpass(8) char(1),
|
|
178 c 0006 3 rest char(8);
|
|
179 c 0006
|
|
180 c 0006 declare /* disk parameter header mask */
|
|
181 c 0006 dphp ptr ext,
|
|
182 c 0006 1 dph_mask based(dphp),
|
|
183 c 0006 2 xlt1 ptr,
|
|
184 c 0006 2 space1(3) bit(8), /*******************/
|
|
185 c 0006 2 mediaf bit(8), /* whf 1/8/83 */
|
|
186 c 0006 2 space2(2) bit(8), /*******************/
|
|
187 c 0006 2 dpbptr ptr,
|
|
188 c 0006 2 csvptr ptr,
|
|
189 c 0006 2 alvptr ptr,
|
|
190 c 0006 2 dirbcb ptr,
|
|
191 c 0006 2 dtabcb ptr,
|
|
192 c 0006 2 hash ptr,
|
|
193 c 0006 /*** 2 hbank ptr, ***/
|
|
194 c 0006
|
|
195 c 0006 xlt ptr; /* save the xlt ptr because of F10 buffer */
|
|
196 c 0006
|
|
197 c 0006 declare /* disk parameter block mask */
|
|
198 c 0006 dpbp ptr external,
|
|
199 c 0006 1 dpb_mask based(dpbp),
|
|
200 c 0006 2 spt fixed(15),
|
|
201 c 0006 2 blkshft fixed(7),
|
|
202 c 0006 2 blkmsk fixed(7),
|
|
203 c 0006 2 extmsk fixed(7),
|
|
204 c 0006 2 dsksiz fixed(15),
|
|
205 c 0006 2 dirmax fixed(15),
|
|
206 c 0006 2 diralv bit(16),
|
|
207 c 0006 2 checked fixed(15),
|
|
208 c 0006 2 offset fixed(15),
|
|
209 c 0006 2 physhf fixed(7),
|
|
210 c 0006 2 phymsk fixed(7),
|
|
211 c 0006
|
|
212 c 0006 ( dspt decimal(7,0),
|
|
213 c 0006 dblk decimal(7,0) ) external;
|
|
214 c 0006
|
|
215 c 0006 declare (
|
|
216 c 0006 dir_blks(32) bit(8),
|
|
217 c 0006 errorcode bit(16)) external;
|
|
218 c 0006
|
|
219 c 0006 declare (
|
|
220 c 0006 MAXSAVE bin fixed(15),
|
|
221 c 0006 enddcnt bin fixed(15),
|
|
222 c 0006 nxfcb bin fixed(15),
|
|
223 c 0006 notsaved bin fixed(15),
|
|
224 c 0006 xptr pointer) external,
|
|
225 c 0006
|
|
226 c 0006 1 XFCBs(1) based(xptr),
|
|
227 c 0006 2 user bin fixed(7),
|
|
228 c 0006 2 name char(11),
|
|
229 c 0006 2 pmode bit(8),
|
|
230 c 0006 2 stamp char(8);
|
|
231 c 0006
|
|
232 c 0006
|
|
233 c 0006 declare
|
|
234 c 0006 INITMSG char(54) static initial
|
|
235 c 0006 ('INITDIR WILL ACTIVATE TIME STAMPS FOR SPECIFIED DRIVE.'),
|
|
236 c 0006 CONFIRM char(60) varying static initial
|
|
237 c 0006 ('Do you want to re-format the directory on drive: '),
|
|
238 c 0006
|
|
239 c 0006 ASKCLEAR char(44) static initial
|
|
240 c 0006 ('Do you want the existing time stamps cleared'),
|
|
241 c 0006 RECOVER char(50) varying static init
|
|
242 c 0006 ('Do you want to recover time/date directory space'),
|
|
243 c 0006 YN char(10) static initial(' (Y/N)? '),
|
|
244 c 0006 YES char(1) static initial('Y'),
|
|
245 c 0006 lyes char(1) static initial('y'),
|
|
246 c 0006 yesno char(1),
|
|
247 c 0006
|
|
248 c 0006 UPPERCASE char(26) static initial
|
|
249 c 0006 ('ABCDEFGHIJKLMNOPQRSTUVWXYZ'),
|
|
250 c 0006 LOWERCASE char(26) static initial
|
|
251 c 0006 ('abcdefghijklmnopqrstuvwxyz'),
|
|
252 c 0006
|
|
253 c 0006 pass1 char(20) static initial
|
|
254 c 0006 ('End of PASS 1.'),
|
|
255 c 0006 ERRORM char(7) static initial
|
|
256 c 0006 ('ERROR: '),
|
|
257 c 0006 TERM char(30) static initial
|
|
258 c 0006 ('INITDIR TERMINATED.'),
|
|
259 c 0006 errvers char(50) static initial
|
|
260 c 0006 ('Requires Concurrent CP/M-86 2.0'),
|
|
261 c 0006 errnotnew char(31) static initial
|
|
262 c 0006 ('Directory already re-formatted.'),
|
|
263 c 0006 errtoobig char(30) static initial
|
|
264 c 0006 ('Not enough room in directory.'),
|
|
265 c 0006 errpass char(15) static initial
|
|
266 c 0006 ('Wrong password.'),
|
|
267 c 0006 errSTRIP char(30) varying static initial
|
|
268 c 0006 ('No time stamps present.'),
|
|
269 c 0006 errMEM char(30) varying static initial
|
|
270 c 0006 ('Not enough available memory.'),
|
|
271 c 0006 errRO char(20) varying static initial
|
|
272 c 0006 ('Disk is READ ONLY.'),
|
|
273 c 0006 errWHAT char(30) varying static initial
|
|
274 c 0006 ('Cannot find last XFCB.'),
|
|
275 c 0006 /*** errRSX char(60) varying static initial
|
|
276 c 0006 ('Cannot re-format the directory with RSXs in memory.'), ***/
|
|
277 c 0006 errunrec char(19) static initial
|
|
278 c 0006 ('Unrecognized drive.'),
|
|
279 c 0006 errDISKACT char(40) varying static initial
|
|
280 c 0006 ('Some other process has an open file.'),
|
|
281 c 0006 errCONSOLE char(40) varying static initial
|
|
282 c 0006 ('INITDIR must be run in foreground only.'),
|
|
283 c 0006 errXREAD char(22) varying static initial
|
|
284 c 0006 ('Fatal XIOS read error.'),
|
|
285 c 0006 errXWRITE char(23) varying static initial
|
|
286 c 0006 ('Fatal XIOS write error.'),
|
|
287 c 0006 errBIOS char(20) static initial
|
|
288 c 0006 ('Cannot select drive.');
|
|
289 c 0006
|
|
290 c 0006 declare (
|
|
291 c 0006 outptr pointer,
|
|
292 c 0006 bufptr1 pointer,
|
|
293 c 0006 bufptr2 pointer,
|
|
294 c 0006 dirptr pointer,
|
|
295 c 0006 drivptr pointer,
|
|
296 c 0006 clearptr pointer,
|
|
297 c 0006
|
|
298 c 0006 nempty bin fixed(15),
|
|
299 c 0006 (nfcbs,nfcbs1) bin fixed(15),
|
|
300 c 0006 lastsfcb bin fixed(15),
|
|
301 c 0006 lastdcnt bin fixed(15),
|
|
302 c 0006 (lasti,lastx) bin fixed(15),
|
|
303 c 0006 lastsect bin fixed(15),
|
|
304 c 0006 cleardcnt bin fixed(15),
|
|
305 c 0006 (gsec,gtrk) bin fixed(15),
|
|
306 c 0006 (dcnt,sect) bin fixed(15),
|
|
307 c 0006 outdcnt bin fixed(15),
|
|
308 c 0006 newdcnt bin fixed(15),
|
|
309 c 0006 outidx bin fixed(7),
|
|
310 c 0006 curdisk bin fixed(7),
|
|
311 c 0006 newlasti bin fixed(7),
|
|
312 c 0006 (sfcbidx,sfcboffs) bin fixed(15),
|
|
313 c 0006 usernum fixed(7),
|
|
314 c 0006 SFCBmark fixed(7) static initial(33),
|
|
315 c 0006 Dlabel bin fixed(7) static initial (32)
|
|
316 c 0006 ) external,
|
|
317 c 0006
|
|
318 c 0006 Redo bit(1),
|
|
319 c 0006 bad bit(1),
|
|
320 c 0006 writeflag bit(1),
|
|
321 c 0006 CLEARSECT bit(1),
|
|
322 c 0006 CLEARSFCB bit(1),
|
|
323 c 0006 labdone bit(1) static initial(false),
|
|
324 c 0006 cversion bit(16),
|
|
325 c 0006 READonly bit(16),
|
|
326 c 0006
|
|
327 c 0006 ptreos pointer,
|
|
328 c 0006 EOS bit(8) static initial('00'b4),
|
|
329 c 0006 CEOS char(1) based (ptreos),
|
|
330 c 0006
|
|
331 c 0006 fcb(32) char(1),
|
|
332 c 0006 fcb0(50) char(1) based (drivptr),
|
|
333 c 0006 dr0 fixed(7) based(drivptr),
|
|
334 c 0006 disks char(16) static initial
|
|
335 c 0006 ('ABCDEFGHIJKLMNOP'),
|
|
336 c 0006 drive bin fixed(7),
|
|
337 c 0006 cdrive char(1);
|
|
338 c 0006
|
|
339 c 0006 declare
|
|
340 c 0006 1 SCB,
|
|
341 c 0006 2 soffs fixed(7),
|
|
342 c 0006 2 seter fixed(7),
|
|
343 c 0006 2 value char(2);
|
|
344 c 0006
|
|
345 c 0006 /**** commented out whf CCP/M-86
|
|
346 c 0006 dcl
|
|
347 c 0006 ccppage bit(8);
|
|
348 c 0006 ****/
|
|
349 c 0006
|
|
350 c 0006 /*************************************************************************
|
|
351 c 0006
|
|
352 c 0006
|
|
353 c 0006 *** MAIN PROGRAM ***
|
|
354 c 0006
|
|
355 c 0006
|
|
356 c 0006 **************************************************************************/
|
|
357 c 0006
|
|
358 c 0006 declare i bin fixed(7);
|
|
359 c 0006
|
|
360 c 0006 cversion = vers();
|
|
361 c 000D if substr(cversion,9,8) ~= '31'b4 |
|
|
362 c 0043 ((substr(cversion,1,8) & '11111101'b1) ~= '14'b4)
|
|
363 c 0043 then call errprint((errvers));
|
|
364 c 0056
|
|
365 c 0056 if openvec() ~= 0 then call errprint(errDISKACT); /*** 1/83 whf ***/
|
|
366 c 006F
|
|
367 c 006F soffs = 23;
|
|
368 c 0074 seter = 0;
|
|
369 c 0079 /*** ccppage = sgscb(addr(SCB)); /* if RSX present then stop */
|
|
370 c 0079 /*** if substr(ccppage,7,1) = '1'b then call errprint(errRSX); */
|
|
371 c 0079
|
|
372 c 0079 drivptr = dfcb0(); /* get drive */
|
|
373 c 0080 drive = dr0;
|
|
374 c 0089 if dr0 > 16 then drive = 0;
|
|
375 c 0097
|
|
376 c 0097 do while(drive = 0); /* none recognized */
|
|
377 c 009E call wrongdisk(i,drive);
|
|
378 c 00A4 call getdisk(i,drive);
|
|
379 c 00AC end;
|
|
380 c 00AC
|
|
381 c 00AC cdrive = substr(disks,drive,1);
|
|
382 c 00C6
|
|
383 c 00C6 curdisk = curdsk(); /* restore BIOS to this */
|
|
384 c 00CC
|
|
385 c 00CC put edit(INITMSG,confirm,cdrive,YN)(skip(2),a,skip,a,a,a);
|
|
386 c 0108 get list(yesno);
|
|
387 c 0121 if yesno ~= YES & yesno ~= lyes then call reboot;
|
|
388 c 0154
|
|
389 c 0154 READonly = rovec(); /* is the drive RO ? */
|
|
390 c 015B if substr(READonly,(17-drive),1) = '1'b then
|
|
391 e 0180 call errprint(errRO);
|
|
392 e 0191
|
|
393 e 0191 call dselect(drive);
|
|
394 e 0197 nfcbs = ((phymsk + 1)*4) - 1; /* # fcbs/physical rcd - 1 */
|
|
395 e 01A9 nfcbs1 = nfcbs + 1;
|
|
396 e 01AD
|
|
397 e 01AD /* everything kosher, lock up system */
|
|
398 e 01AD if syslock() ~= 0 then call errprint(errDISKACT); /*** 1/83 whf ***/
|
|
399 e 01C5
|
|
400 e 01C5 dirptr = addr(dir_fcb(0));
|
|
401 e 01CB dcnt = 0;
|
|
402 e 01D1 call read_sector(dcnt,dirptr);
|
|
403 e 01D7
|
|
404 e 01D7 call allxfcb; /* allocate XFCB data space */
|
|
405 e 01DA if dirm(3).user = SFCBmark then call query; /* recover SFCB space? */
|
|
406 e 01EA call countdir; /* count number of directory entries */
|
|
407 e 01ED
|
|
408 e 01ED if conlock() ~= 0 then call errprint(errCONSOLE); /*** 1/83 whf ***/
|
|
409 e 0205
|
|
410 e 0205 call init;
|
|
411 e 0208 call restore;
|
|
412 e 020B
|
|
413 e 020B /********************************************************************/
|
|
414 e 020B
|
|
415 e 020B
|
|
416 e 020B wrongdisk: procedure(i,drive) external;
|
|
417 e 020B declare (i,j,drive) bin fixed(7);
|
|
418 e 0218
|
|
419 e 0218 put list(ERRORM,errunrec);
|
|
420 e 023A
|
|
421 e 023A /** put skip list('DRIVE: ');
|
|
422 e 023A j = i;
|
|
423 e 023A ptreos = addr(EOS);
|
|
424 e 023A do while(fcb0(j) ~= ' ' & fcb0(j) ~= CEOS);
|
|
425 e 023A put edit(fcb0(j))(a);
|
|
426 e 023A j = j + 1;
|
|
427 e 023A end;
|
|
428 e 023A **/
|
|
429 e 023A put skip;
|
|
430 c 024C
|
|
431 c 024C end wrongdisk;
|
|
432 e 024C
|
|
433 e 024C getdisk: procedure(i,drive) external;
|
|
434 e 024C declare (i,drive) bin fixed(7);
|
|
435 e 025A
|
|
436 e 025A put skip list('Enter Drive: ');
|
|
437 e 0276 get list(fcb0(i));
|
|
438 e 02A1 fcb0(i) = translate(fcb0(i),UPPERCASE,LOWERCASE);
|
|
439 e 02EA fcb0(i+1) = ':';
|
|
440 e 0307
|
|
441 e 0307 drive = index(disks,fcb0(i));
|
|
442 c 0339
|
|
443 c 0339 end getdisk;
|
|
444 e 0339
|
|
445 e 0339
|
|
446 e 0339 /**************************************************************************/
|
|
447 e 0339
|
|
448 e 0339
|
|
449 e 0339 init: procedure external;
|
|
450 e 0339
|
|
451 e 0339 declare
|
|
452 e 033C (i,j,k,l) bin fixed(15);
|
|
453 e 033C
|
|
454 e 033C lastx = nxfcb;
|
|
455 e 0342 sect = sect - 1;
|
|
456 e 0346 dcnt = dcnt - 1; /* reset to good dcnt */
|
|
457 e 034A
|
|
458 e 034A if Redo then do;
|
|
459 e 0353 newdcnt = lastdcnt;
|
|
460 e 0359 newlasti = lasti;
|
|
461 e 0362 end;
|
|
462 e 0362 else do;
|
|
463 e 0362 lastsfcb = lastdcnt/3 + 1;
|
|
464 e 036F newdcnt = lastdcnt + lastsfcb + (2 - mod(lastdcnt,3));
|
|
465 e 0390 if newdcnt > dirmax then do;
|
|
466 e 03A1 lastdcnt = dirmax - nempty;
|
|
467 e 03B0 lastsfcb = lastdcnt/3 + 1;
|
|
468 e 03BA newdcnt = lastdcnt + lastsfcb + (2 - mod(lastdcnt,3));
|
|
469 e 03DB
|
|
470 e 03DB if newdcnt > dirmax then
|
|
471 e 03E9 call errprint(errtoobig);
|
|
472 e 03FC
|
|
473 e 03FC call collapse; /* remove all empties by
|
|
474 e 03FF collapsing dir from top */
|
|
475 e 03FF lastsfcb = lastdcnt/3 + 1;
|
|
476 e 040C newdcnt = lastdcnt + lastsfcb + (2 - mod(lastdcnt,3));
|
|
477 e 042D if newdcnt > dirmax then
|
|
478 e 043B call errprint(errtoobig);
|
|
479 e 044E end;
|
|
480 e 044E newlasti = mod(newdcnt,nfcbs1) - 3 + mod(lastdcnt,3);
|
|
481 e 0472 end;
|
|
482 e 0472
|
|
483 e 0472 outptr = addr(buffer2(0)); /* want to clear last read
|
|
484 e 0478 sector...buffer2 only used
|
|
485 e 0478 in collapse so it is free */
|
|
486 e 0478 call clearout;
|
|
487 e 047B clearptr = outptr;
|
|
488 e 0481 outptr = addr(outbuf(0));
|
|
489 e 0487 call clearout; /* zero output buffer */
|
|
490 e 048A
|
|
491 e 048A
|
|
492 e 048A /***********************************************************************/
|
|
493 e 048A
|
|
494 e 048A
|
|
495 e 048A do while(lastsect < sect ); /* clear from end of dir */
|
|
496 e 0493 call write_sector(dcnt,outptr);
|
|
497 e 0499 dcnt = dcnt - nfcbs1;
|
|
498 e 04A0 sect = sect - 1;
|
|
499 e 04A6 end;
|
|
500 e 04A6
|
|
501 e 04A6 if (nempty - 1) ~= dirmax then do; /* if there are files on dir */
|
|
502 e 04B4
|
|
503 e 04B4 /* bottom of directory is
|
|
504 e 04B4 now all E5 and 21...
|
|
505 e 04B4 it is positioned to the
|
|
506 e 04B4 last good sector of the old
|
|
507 e 04B4 directory. */
|
|
508 e 04B4 dcnt = lastdcnt;
|
|
509 e 04BA enddcnt = newdcnt;
|
|
510 e 04C0 call read_sector(dcnt,dirptr); /* read last good sector */
|
|
511 e 04C6
|
|
512 e 04C6 outidx = newlasti; /* index into out buffer */
|
|
513 e 04CC call buildnew(lasti); /* fill in outbuff from the
|
|
514 e 04D2 bottom up...need this call
|
|
515 e 04D2 because lasti may be in
|
|
516 e 04D2 middle of read buffer */
|
|
517 e 04D2 do while(dcnt >= 0);
|
|
518 e 04D9 /* as soon as we are finished
|
|
519 e 04D9 with reading old sector,
|
|
520 e 04D9 then go clear it. This
|
|
521 e 04D9 should limit possibility
|
|
522 e 04D9 that duplicate FCB's occur.
|
|
523 e 04D9 */
|
|
524 e 04D9 call read_sector(dcnt,dirptr);
|
|
525 e 04DF call buildnew(nfcbs);
|
|
526 e 04E9 end;
|
|
527 e 04E9
|
|
528 e 04E9 end; /* virgin dir */
|
|
529 e 04E9
|
|
530 e 04E9 else call write_sector(0,outptr); /* write last sector */
|
|
531 e 04EF
|
|
532 e 04EF do while(notsaved > 0);
|
|
533 e 04F6 call moreXFCB;
|
|
534 c 04FC end;
|
|
535 c 04FC
|
|
536 c 04FC end init;
|
|
537 e 04FC
|
|
538 e 04FC /************************************************************************/
|
|
539 e 04FC
|
|
540 e 04FC
|
|
541 e 04FC strip: procedure external;
|
|
542 e 04FC
|
|
543 e 04FC /* remove all SFCB from directory by jamming
|
|
544 e 04FC E5 into user field. Also turn off time/date
|
|
545 e 04FC stamping in DIR LABEL. */
|
|
546 e 04FC
|
|
547 e 04FC declare (i,j) bin fixed(7),
|
|
548 e 04FF 1 direct(0:127) based(dirptr),
|
|
549 e 04FF 2 junk1 char(12),
|
|
550 e 04FF 2 ext bit(8),
|
|
551 e 04FF 2 rest char(19),
|
|
552 e 04FF
|
|
553 e 04FF olddcnt bin fixed(15);
|
|
554 e 04FF
|
|
555 e 04FF
|
|
556 e 04FF dcnt = 0;
|
|
557 e 0505
|
|
558 e 0505 do while(dcnt <= dirmax);
|
|
559 e 0516
|
|
560 e 0516 call read_sector(dcnt,dirptr);
|
|
561 e 051C
|
|
562 e 051C olddcnt = dcnt;
|
|
563 e 0522 do i = 0 to nfcbs while(dcnt <= dirmax);
|
|
564 e 0555
|
|
565 e 0555 if ~labdone then
|
|
566 e 0560 if dirm(i).user = Dlabel then do;
|
|
567 e 0575 call getpass(i);
|
|
568 e 057B direct(i).ext = direct(i).ext & '10000001'b;
|
|
569 e 058E labdone = true;
|
|
570 e 0593 end;
|
|
571 e 0593
|
|
572 e 0593 if dirm(i).user = SFCBmark then
|
|
573 e 05A8 dir_fcb(i).user = 'E5'b4;
|
|
574 e 05B7
|
|
575 e 05B7 dcnt = dcnt + 1;
|
|
576 e 05C2 end;
|
|
577 e 05C2
|
|
578 e 05C2 call write_sector(olddcnt,dirptr);
|
|
579 c 05CC end;
|
|
580 c 05CC
|
|
581 c 05CC end strip;
|
|
582 e 05CC
|
|
583 e 05CC
|
|
584 e 05CC /*****************************************************************************/
|
|
585 e 05CC
|
|
586 e 05CC
|
|
587 e 05CC
|
|
588 e 05CC countdir: procedure external;
|
|
589 e 05CC declare i bin fixed(7);
|
|
590 e 05CF
|
|
591 e 05CF /* there are 5 valid sets of codes in
|
|
592 e 05CF the user field:
|
|
593 e 05CF
|
|
594 e 05CF E5 - empty
|
|
595 e 05CF 0-15 - user numbers
|
|
596 e 05CF 32 - Directory label
|
|
597 e 05CF 33 - SFCB marker
|
|
598 e 05CF 16-31 - XFCB marker
|
|
599 e 05CF
|
|
600 e 05CF This routine counts the # of used
|
|
601 e 05CF directory slots ignoring E5.
|
|
602 e 05CF NOTE: if SFCB present then last
|
|
603 e 05CF slot = SFCB */
|
|
604 e 05CF
|
|
605 e 05CF Redo = false;
|
|
606 e 05D4 nempty = 0;
|
|
607 e 05DA sect = 0;
|
|
608 e 05E0 nxfcb = 0;
|
|
609 e 05E6 notsaved = 0;
|
|
610 e 05EC bad = true;
|
|
611 e 05F1 /* If dir is already time stamped then
|
|
612 e 05F1 SFCBs should appear in every sector,
|
|
613 e 05F1 notably the first sector. Thus,
|
|
614 e 05F1 test first sector. If first sector
|
|
615 e 05F1 has SFCB then all do. If none in
|
|
616 e 05F1 first & they appear later then
|
|
617 e 05F1 INITDIR was probably interrupted.
|
|
618 e 05F1 In that case, zap the found SFCB's
|
|
619 e 05F1 and treat dir as virgin. */
|
|
620 e 05F1
|
|
621 e 05F1 if dirm(3).user = SFCBmark then bad = false;
|
|
622 e 0603
|
|
623 e 0603 do while(dcnt <= dirmax);
|
|
624 e 0614 do i = 0 to nfcbs while(dcnt <= dirmax);
|
|
625 e 0647 if dir_fcb(i).user ~= 'E5'b4 then do;
|
|
626 e 0663 usernum = dirm(i).user;
|
|
627 e 0676
|
|
628 e 0676 /* assume sfcb's were caught before this */
|
|
629 e 0676 if usernum > 15 & usernum < 32 then
|
|
630 e 0692 call getXFCB(i);
|
|
631 e 069A
|
|
632 e 069A /* if LABEL then check for password...
|
|
633 e 069A may terminate in getpass */
|
|
634 e 069A
|
|
635 e 069A else if usernum = Dlabel then call getpass(i);
|
|
636 e 06A9
|
|
637 e 06A9 if (usernum < 33) | (~bad & usernum = 33) then
|
|
638 e 06CE do;
|
|
639 e 06CE
|
|
640 e 06CE lasti = i;
|
|
641 e 06D5 lastsect = sect;
|
|
642 e 06DB lastdcnt = dcnt;
|
|
643 e 06E3 end; /* bad...*/
|
|
644 e 06E3 else if usernum = 33 then nempty = nempty + 1;
|
|
645 e 06F0
|
|
646 e 06F0 end; /* E5 ... */
|
|
647 e 06F0 else nempty = nempty + 1;
|
|
648 e 06F4 dcnt = dcnt + 1;
|
|
649 e 06FF end;
|
|
650 e 06FF
|
|
651 e 06FF sect = sect + 1;
|
|
652 e 0703 call read_sector(dcnt,dirptr);
|
|
653 e 070C end;
|
|
654 e 070C
|
|
655 e 070C if ~Redo then lastsfcb = lastdcnt/3 + 1;
|
|
656 c 0725
|
|
657 c 0725 end countdir;
|
|
658 e 0725
|
|
659 e 0725 getXFCB: procedure(i) external;
|
|
660 e 0725 declare i bin fixed(7);
|
|
661 e 072D
|
|
662 e 072D if nxfcb <= MAXSAVE then do;
|
|
663 e 0739 nxfcb = nxfcb + 1;
|
|
664 e 073D XFCBs(nxfcb).user = usernum - 16;
|
|
665 e 0755 XFCBs(nxfcb).name = infcb2(i).name;
|
|
666 e 0786 XFCBs(nxfcb).pmode = infcb2(i).pmode;
|
|
667 e 07AD XFCBs(nxfcb).stamp = infcb2(i).stamp;
|
|
668 e 07E1 end;
|
|
669 e 07E1 else notsaved = notsaved + 1;
|
|
670 c 07E6
|
|
671 c 07E6 end getXFCB;
|
|
672 e 07E6
|
|
673 e 07E6
|
|
674 e 07E6 allxfcb: procedure external;
|
|
675 e 07E6
|
|
676 e 07E6 /* allocates largest available block of space
|
|
677 e 07E6 to be used in storing XFCB info.
|
|
678 e 07E6 maxwds & allwds use word units */
|
|
679 e 07E6
|
|
680 e 07E6 declare maxwds entry returns(fixed(15)),
|
|
681 e 07E8 allwds entry(fixed(15)) returns(pointer),
|
|
682 e 07E8 size bin fixed(15);
|
|
683 e 07E8
|
|
684 e 07E8 size = maxwds(); /* get largest block in free space */
|
|
685 e 07EF xptr = allwds(size); /* reserve it */
|
|
686 e 07F9 MAXSAVE = 2*(size/21); /* # XFCBs that can be saved */
|
|
687 e 0807 if MAXSAVE <= 10 then call errprint(errMEM);
|
|
688 c 0820
|
|
689 c 0820 end allxfcb;
|
|
690 e 0820
|
|
691 e 0820
|
|
692 e 0820 query: procedure external;
|
|
693 e 0820
|
|
694 e 0820 if bad then return;
|
|
695 e 082C
|
|
696 e 082C put skip(2) list(errnotnew);
|
|
697 e 0848
|
|
698 e 0848 /* check to see if user wants
|
|
699 e 0848 to strip SFCB's */
|
|
700 e 0848 if ~asker(RECOVER) then do;
|
|
701 e 0861 Redo = true;
|
|
702 e 0866 CLEARSFCB = false;
|
|
703 e 086B if asker(ASKCLEAR) then do;
|
|
704 e 0882 CLEARSFCB = true;
|
|
705 e 0887 return;
|
|
706 e 088A end;
|
|
707 e 088A end;
|
|
708 e 088A else call strip; /* this will end down here
|
|
709 e 088D after stripping */
|
|
710 e 088D
|
|
711 e 088D call restore; /* dir is already formattted &
|
|
712 c 0891 user does not want to clear
|
|
713 c 0891 old SFCB's....just stop */
|
|
714 c 0891
|
|
715 c 0891 end query;
|
|
716 e 0891
|
|
717 e 0891 buildnew: procedure(endidx) external;
|
|
718 e 0891 declare (i,j,k,endidx) bin fixed(15);
|
|
719 e 0899
|
|
720 e 0899 declare 1 ot(0:127) based(outptr),
|
|
721 e 0899 2 user fixed(7),
|
|
722 e 0899 2 fname char(8),
|
|
723 e 0899 2 ftype char(3),
|
|
724 e 0899 2 rest char(20);
|
|
725 e 0899
|
|
726 e 0899 /* build output buffer from
|
|
727 e 0899 input(end) to input(0).
|
|
728 e 0899 k => refers to input */
|
|
729 e 0899 k = endidx;
|
|
730 e 08A2 do while(k >= 0);
|
|
731 e 08AC usernum = dirm(k).user;
|
|
732 e 08BE
|
|
733 e 08BE outb(outidx).rest = infcb(k).rest;
|
|
734 e 08E8
|
|
735 e 08E8 if usernum = SFCBmark then do;
|
|
736 e 08F1 if bad then outb2(outidx).user = 'E5'b4;
|
|
737 e 090D else if CLEARSFCB then outb3(outidx).rest = zeroes;
|
|
738 e 0935 end;
|
|
739 e 0935
|
|
740 e 0935 if usernum < 16 then do;
|
|
741 e 093C if nxfcb > 0 then /* if fcb is ex=0 and XFCB
|
|
742 e 0943 exists then check for
|
|
743 e 0943 possible SFCB update */
|
|
744 e 0943 call putXFCB(k);
|
|
745 e 094F end;
|
|
746 e 094F
|
|
747 e 094F if ~Redo & mod(outidx,4) = 0 then outidx = outidx - 2;
|
|
748 e 0980 else outidx = outidx - 1;
|
|
749 e 0984
|
|
750 e 0984 k = k - 1;
|
|
751 e 0988 dcnt = dcnt - 1;
|
|
752 e 098C
|
|
753 e 098C if outidx < 0 then do;
|
|
754 e 0993 if dcnt > 14 then
|
|
755 e 099A if mod(dcnt + 1,nfcbs1) = 0 then
|
|
756 e 09AC call write_sector(dcnt + 1,clearptr);
|
|
757 e 09B9 call write_sector(newdcnt,outptr);
|
|
758 e 09BF newdcnt = newdcnt - nfcbs1;
|
|
759 e 09C6 outidx = nfcbs - 1;
|
|
760 e 09CD if Redo then outidx = outidx + 1;
|
|
761 c 09DE end;
|
|
762 c 09DE end;
|
|
763 c 09DE
|
|
764 c 09DE end buildnew;
|
|
765 e 09DE
|
|
766 e 09DE
|
|
767 e 09DE /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
|
|
768 e 09DE
|
|
769 e 09DE
|
|
770 e 09DE compare: procedure(k) returns(fixed(7)) external;
|
|
771 e 09DE
|
|
772 e 09DE declare (i,j,k) bin fixed(7),
|
|
773 e 09E6 1 direc(0:127) based(dirptr),
|
|
774 e 09E6 2 user fixed(7),
|
|
775 e 09E6 2 name(11) char(1),
|
|
776 e 09E6 2 rest char(20),
|
|
777 e 09E6
|
|
778 e 09E6 1 XFCB2(1) based(xptr),
|
|
779 e 09E6 2 user char(1),
|
|
780 e 09E6 2 name(11) char(1),
|
|
781 e 09E6 2 rest char(9);
|
|
782 e 09E6
|
|
783 e 09E6 /* compare fcb with XFCB list;
|
|
784 e 09E6 return position in list if
|
|
785 e 09E6 found, 0 otherwise.
|
|
786 e 09E6 Nullify usernum field in
|
|
787 e 09E6 XFCB list (=99) if found.
|
|
788 e 09E6 Decrement #xfcb as well.*/
|
|
789 e 09E6 do i = 1 to nxfcb;
|
|
790 e 09FD if XFCBs(i).user ~= 99 then do;
|
|
791 e 0A18 if XFCBs(i).user = direc(k).user then do;
|
|
792 e 0A45
|
|
793 e 0A45 do j = 1 to 11;
|
|
794 e 0A51 if direc(k).name(j) ~= XFCB2(i).name(j)
|
|
795 e 0A94 then go to outx;
|
|
796 e 0A9C end;
|
|
797 e 0A9C
|
|
798 e 0A9C /* found a match */
|
|
799 e 0A9C XFCBs(i).user = 99;
|
|
800 e 0AB2 nxfcb = nxfcb - 1;
|
|
801 e 0AB6 return(i);
|
|
802 e 0AC1
|
|
803 e 0AC1 outx: end;
|
|
804 e 0AC1 end;
|
|
805 e 0AC1 end;
|
|
806 e 0AC1
|
|
807 e 0AC1 return(0);
|
|
808 c 0AC4
|
|
809 c 0AC4 end compare;
|
|
810 e 0AC4
|
|
811 e 0AC4 moreXFCB: procedure external;
|
|
812 e 0AC4 /* we could not store all the xfcb's in memory
|
|
813 e 0AC4 available, so now must make another pass &
|
|
814 e 0AC4 store as many XFCB as possible.
|
|
815 e 0AC4 'notsaved' > 0 ==> we may have to
|
|
816 e 0AC4 do this again. */
|
|
817 e 0AC4 declare (i,k) bin fixed(7);
|
|
818 e 0AC7
|
|
819 e 0AC7 dcnt = enddcnt; /* go to end of directory */
|
|
820 e 0ACD if ~findXFCB(k) then /* work backwards trying to find
|
|
821 e 0ADB last known XFCB...if not found
|
|
822 e 0ADB then something very strange has
|
|
823 e 0ADB happened; */
|
|
824 e 0ADB call errprint(errWHAT);
|
|
825 e 0AEC
|
|
826 e 0AEC notsaved = 0; /* now in last sector where last XFCB
|
|
827 e 0AF2 occurs...look for other XFCB that
|
|
828 e 0AF2 we know is there. */
|
|
829 e 0AF2 nxfcb = 0;
|
|
830 e 0AF8
|
|
831 e 0AF8 dcnt = dcnt + 1;
|
|
832 e 0AFC lastdcnt = dcnt; /* save position of last XFCB + 1 */
|
|
833 e 0B02 lasti = k + 1; /* index in sector */
|
|
834 e 0B0A do while(dcnt <= enddcnt);
|
|
835 e 0B16 do i = k+1 to nfcbs while(dcnt <= enddcnt);
|
|
836 e 0B45 usernum = dirm(i).user;
|
|
837 e 0B58 if usernum > 15 & usernum < 32 then call getXFCB(i);
|
|
838 e 0B7A dcnt = dcnt + 1;
|
|
839 e 0B84 end;
|
|
840 e 0B84 k = 0;
|
|
841 e 0B89 call read_sector(dcnt,dirptr);
|
|
842 e 0B92 end;
|
|
843 e 0B92
|
|
844 e 0B92 dcnt = 0; /* go to start of dir */
|
|
845 e 0B98 do while(dcnt <= enddcnt);
|
|
846 e 0BA4 call read_sector(dcnt,dirptr);
|
|
847 e 0BAA outdcnt = dcnt;
|
|
848 e 0BB0 writeflag = false; /* putXFCB sets when it finds a
|
|
849 e 0BB5 match */
|
|
850 e 0BB5
|
|
851 e 0BB5 do k = 0 to nfcbs while(dcnt <= enddcnt);
|
|
852 e 0BE1 outidx = k;
|
|
853 e 0BE7 if dirm(k).user < 16 then call putXFCB(k);
|
|
854 e 0C00 dcnt = dcnt + 1;
|
|
855 e 0C0A end;
|
|
856 e 0C0A if writeflag then call write_sector(outdcnt,dirptr);
|
|
857 c 0C1D end;
|
|
858 c 0C1D
|
|
859 c 0C1D end moreXFCB;
|
|
860 e 0C1D
|
|
861 e 0C1D findXFCB: procedure(idx) returns(bit(1)) external;
|
|
862 e 0C1D
|
|
863 e 0C1D /* find the last known XFCB...starts from the
|
|
864 e 0C1D last written sector in the dir and goes
|
|
865 e 0C1D backwards...hopefully that's faster */
|
|
866 e 0C1D declare idx fixed(7);
|
|
867 e 0C25
|
|
868 e 0C25 do while(dcnt > 0);
|
|
869 e 0C2F call read_sector(dcnt,dirptr);
|
|
870 e 0C35 do idx = 0 to nfcbs while(dcnt > 0);
|
|
871 e 0C65 usernum = dirm(idx).user;
|
|
872 e 0C7B if usernum > 15 & usernum < 32 then
|
|
873 e 0C97 if XFCBs(lastx).name = infcb2(idx).name then
|
|
874 e 0CCC return(true);
|
|
875 e 0CCF dcnt = dcnt - 1;
|
|
876 e 0CDF end;
|
|
877 e 0CDF end;
|
|
878 e 0CDF
|
|
879 e 0CDF return(false); /* big trouble...*/
|
|
880 c 0CE2
|
|
881 c 0CE2 end findXFCB;
|
|
882 e 0CE2
|
|
883 e 0CE2
|
|
884 e 0CE2 putXFCB: procedure(k) external;
|
|
885 e 0CE2 /* if this is extent 0 fold and names match
|
|
886 e 0CE2 then update SFCB from XFCB */
|
|
887 e 0CE2 declare (k,j) fixed(7);
|
|
888 e 0CEA
|
|
889 e 0CEA if dirm(k).fext <= dpb_mask.extmsk then do;
|
|
890 e 0D0C j = compare(k);
|
|
891 e 0D1B if j ~= 0 then do;
|
|
892 e 0D25
|
|
893 e 0D25 /* fcb matches XFCB...
|
|
894 e 0D25 update the SFCB */
|
|
895 e 0D25 sfcboffs = mod(outidx+1,4);
|
|
896 e 0D36 sfcbidx = outidx + (4 - sfcboffs);
|
|
897 e 0D45 outb4(sfcbidx).sfcb(sfcboffs).stamps =
|
|
898 e 0D7F XFCBs(j).stamp;
|
|
899 e 0D7F outb4(sfcbidx).sfcb(sfcboffs).mode =
|
|
900 e 0DAE XFCBs(j).pmode;
|
|
901 e 0DAE writeflag = true;
|
|
902 c 0DB4 end;
|
|
903 c 0DB4 end; /* extent 0 ? */
|
|
904 c 0DB4
|
|
905 c 0DB4 end putXFCB;
|
|
906 e 0DB4
|
|
907 e 0DB4
|
|
908 e 0DB4 errprint: procedure(msg) external;
|
|
909 e 0DB4 declare
|
|
910 e 0DBB msg char(60) varying;
|
|
911 e 0DBB
|
|
912 e 0DBB put edit(ERRORM,msg,TERM)(skip(2),a,a,skip,a);
|
|
913 e 0DEF put skip(2);
|
|
914 e 0E00
|
|
915 e 0E00 call restore;
|
|
916 c 0E04
|
|
917 c 0E04 end errprint;
|
|
918 e 0E04
|
|
919 e 0E04
|
|
920 e 0E04 asker: procedure(msg) returns(bit(1)) external;
|
|
921 e 0E04
|
|
922 e 0E04 declare msg char(60) varying;
|
|
923 e 0E0C
|
|
924 e 0E0C put skip list(msg,YN);
|
|
925 e 0E34 get list(yesno);
|
|
926 e 0E4D
|
|
927 e 0E4D if yesno ~= YES & yesno ~= lyes then return(false);
|
|
928 e 0E80
|
|
929 e 0E80 return(true);
|
|
930 c 0E83
|
|
931 c 0E83 end asker;
|
|
932 e 0E83
|
|
933 e 0E83
|
|
934 e 0E83 clearout: procedure external;
|
|
935 e 0E83 declare
|
|
936 e 0E86 (i,j) bin fixed(7);
|
|
937 e 0E86
|
|
938 e 0E86 do i = 0 to nfcbs;
|
|
939 e 0E9A if mod(i+1,4) ~= 0 then outb2(i).user = 'E5'b4;
|
|
940 e 0EBF else outb3(i).user = SFCBmark;
|
|
941 e 0ED2
|
|
942 e 0ED2 do j = 1 to 31;
|
|
943 e 0EDE outb3(i).rest(j) = '00000000'b;
|
|
944 c 0F02 end;
|
|
945 c 0F02 end;
|
|
946 c 0F02
|
|
947 c 0F02 end clearout;
|
|
948 e 0F02
|
|
949 e 0F02 getpass: procedure(fcbx) external;
|
|
950 e 0F02 /* Drive may be password protected...
|
|
951 e 0F02 Get passw from user and compare
|
|
952 e 0F02 with Password in label.
|
|
953 e 0F02 Label password is encoded by first
|
|
954 e 0F02 reversing each char nibble and then
|
|
955 e 0F02 XOR'ing with the sum of the pass.
|
|
956 e 0F02 S2 in label = that sum. */
|
|
957 e 0F02
|
|
958 e 0F02 declare
|
|
959 e 0F0A passwd(8) bit(8) based(passptr),
|
|
960 e 0F0A
|
|
961 e 0F0A passptr pointer,
|
|
962 e 0F0A convptr pointer,
|
|
963 e 0F0A pchar(8) bit(8),
|
|
964 e 0F0A cvpass(8) char(1) based(convptr),
|
|
965 e 0F0A inpass char(8),
|
|
966 e 0F0A (i,j,fcbx) bin fixed(7);
|
|
967 e 0F0A
|
|
968 e 0F0A labdone = true;
|
|
969 e 0F0F
|
|
970 e 0F0F passptr = addr(dirm(fcbx).diskpass);
|
|
971 e 0F27 convptr = addr(pchar(1));
|
|
972 e 0F2D
|
|
973 e 0F2D do i = 1 to 8; /* XOR each character */
|
|
974 e 0F39 pchar(i) = bool(passwd(i),dirm(fcbx).fs1,'0110'b);
|
|
975 e 0F78 end;
|
|
976 e 0F78
|
|
977 e 0F78 if cvpass(8) <= ' ' then return; /* no password */
|
|
978 e 0F93
|
|
979 e 0F93 put skip(2) list('Directory is password protected.');
|
|
980 e 0FAF put skip list('Password, please. >');
|
|
981 e 0FCB get list(inpass);
|
|
982 e 0FE4 inpass = translate(inpass,UPPERCASE,LOWERCASE);
|
|
983 e 100D
|
|
984 e 100D j = 8;
|
|
985 e 1012 do i = 1 to 8;
|
|
986 e 101E if substr(inpass,i,1) ~= cvpass(j) then call errprint(errpass);
|
|
987 e 1062 j = j - 1;
|
|
988 c 106D end;
|
|
989 c 106D
|
|
990 c 106D end getpass;
|
|
991 e 106D
|
|
992 e 106D collapse: procedure external;
|
|
993 e 106D
|
|
994 e 106D declare whichbuf bin fixed(7),
|
|
995 e 1070 enddcnt bin fixed(15),
|
|
996 e 1070 (i,nout1,nout2) bin fixed(7);
|
|
997 e 1070
|
|
998 e 1070 dcnt = 0;
|
|
999 e 1076 sect = 0;
|
|
1000 e 107C outdcnt = 0;
|
|
1001 e 1082 whichbuf = 0;
|
|
1002 e 1087 nout1 = 0;
|
|
1003 e 108C nout2 = 0;
|
|
1004 e 1091 lastsect = 0;
|
|
1005 e 1097 enddcnt = lastdcnt + nempty;
|
|
1006 e 10A1 lastdcnt = 0;
|
|
1007 e 10A7 bufptr1 = addr(outbuf(0));
|
|
1008 e 10AD bufptr2 = addr(buffer2(0));
|
|
1009 e 10B3
|
|
1010 e 10B3 do while(dcnt <= enddcnt); /* read up to last dcnt */
|
|
1011 e 10BF
|
|
1012 e 10BF call read_sector(dcnt,dirptr);
|
|
1013 e 10C5
|
|
1014 e 10C5 do i = 0 to nfcbs while(dcnt <= enddcnt);
|
|
1015 e 10F1 if dir_fcb(i).user ~= 'E5'b4 &
|
|
1016 e 1128 dirm(i).user ~= SFCBmark then do;
|
|
1017 e 1128
|
|
1018 e 1128 if whichbuf = 0 then
|
|
1019 e 112F call fill(bufptr1,i,nout1,whichbuf);
|
|
1020 e 1137 else call fill(bufptr2,i,nout2,whichbuf);
|
|
1021 e 113D end;
|
|
1022 e 113D dcnt = dcnt + 1;
|
|
1023 e 1147 end;
|
|
1024 e 1147
|
|
1025 e 1147 sect = sect + 1;
|
|
1026 e 114B if nout1 = nfcbs1 then call flush_write(nout1,bufptr1);
|
|
1027 e 115D else if nout2 = nfcbs1 then call flush_write(nout2,bufptr2);
|
|
1028 e 1170 end;
|
|
1029 e 1170
|
|
1030 e 1170 dcnt = dcnt - 1; /* fill unused slots in buffer
|
|
1031 e 1174 with empty...scratch rest of
|
|
1032 e 1174 dir */
|
|
1033 e 1174 if whichbuf = 0 then call fill2(bufptr1,nout1);
|
|
1034 e 1183 else call fill2(bufptr2,nout2);
|
|
1035 c 118A
|
|
1036 c 118A end collapse;
|
|
1037 e 118A
|
|
1038 e 118A fill: proc(bufptr,i,nout,whichbuf);
|
|
1039 e 118A declare bufptr pointer,
|
|
1040 e 1197 (i,j,nout) bin fixed(7),
|
|
1041 e 1197 whichbuf bin fixed(7),
|
|
1042 e 1197
|
|
1043 e 1197 1 buffer(0:127) based(bufptr),
|
|
1044 e 1197 2 out char(32);
|
|
1045 e 1197
|
|
1046 e 1197 buffer(nout).out = infcb(i).rest;
|
|
1047 e 11CA
|
|
1048 e 11CA lastdcnt = lastdcnt + 1;
|
|
1049 e 11CE nout = nout + 1;
|
|
1050 e 11D4 if nout = nfcbs1 then whichbuf = mod((whichbuf + 1),2);
|
|
1051 c 1202
|
|
1052 c 1202 end fill;
|
|
1053 e 1202
|
|
1054 e 1202 flush_write: proc(nout,bufptr);
|
|
1055 e 1202 declare nout bin fixed(7),
|
|
1056 e 120F bufptr pointer;
|
|
1057 e 120F
|
|
1058 e 120F /* always behind the read...thus don't
|
|
1059 e 120F need to test to see if read sector =
|
|
1060 e 120F write sector. */
|
|
1061 e 120F call write_sector(outdcnt,bufptr);
|
|
1062 e 121B outdcnt = outdcnt + nfcbs1;
|
|
1063 e 1222 nout = 0;
|
|
1064 e 1229 lastsect = lastsect + 1;
|
|
1065 c 122E
|
|
1066 c 122E end flush_write;
|
|
1067 e 122E
|
|
1068 e 122E fill2: proc(bufptr,nout);
|
|
1069 e 122E
|
|
1070 e 122E declare (i,j,nout) bin fixed(7),
|
|
1071 e 123C bufptr pointer,
|
|
1072 e 123C 1 buffer(0:127) based(bufptr),
|
|
1073 e 123C 2 user bit(8),
|
|
1074 e 123C 2 rest(31) bit(8);
|
|
1075 e 123C
|
|
1076 e 123C do i = nout to nfcbs;
|
|
1077 e 1254 buffer(i).user = 'E5'b4;
|
|
1078 e 1267 do j = 1 to 31;
|
|
1079 e 1273 buffer(i).rest(j) = '00000000'b;
|
|
1080 e 1298 end;
|
|
1081 e 1298 end;
|
|
1082 e 1298
|
|
1083 e 1298 lastdcnt = lastdcnt - 1;
|
|
1084 e 129C lasti = nout - 1;
|
|
1085 e 12A7 call flush_write(nout,bufptr);
|
|
1086 e 12B9
|
|
1087 e 12B9 do i = 0 to nfcbs; /* prepare empty sector */
|
|
1088 e 12CF buffer(i).user = 'E5'b4;
|
|
1089 e 12E2 do j = 1 to 31;
|
|
1090 e 12EE buffer(i).rest(j) = '00000000'b;
|
|
1091 e 1313 end;
|
|
1092 e 1313 end;
|
|
1093 e 1313
|
|
1094 e 1313 /* clear rest of directory */
|
|
1095 e 1313 do while (outdcnt < dcnt);
|
|
1096 e 131C call write_sector(outdcnt,bufptr);
|
|
1097 e 1328 outdcnt = outdcnt + nfcbs1;
|
|
1098 c 1332 end;
|
|
1099 c 1332
|
|
1100 c 1332 end fill2;
|
|
1101 e 1332
|
|
1102 e 1332 restore: procedure external;
|
|
1103 e 1332 declare
|
|
1104 e 1334 1 xdpb based(dpbp),
|
|
1105 e 1334 2 front char(11),
|
|
1106 e 1334 2 chkvecb bit(16);
|
|
1107 e 1334
|
|
1108 e 1334 /* if selected drive was permanent,
|
|
1109 e 1334 then must force login of drive to
|
|
1110 e 1334 restore good directory buffers and
|
|
1111 e 1334 hash tables */
|
|
1112 e 1334 /* In CCP/M-86, this is done by setting
|
|
1113 e 1334 the login sequence number in the DPH
|
|
1114 e 1334 to zero, thus ensuring hard disks wi
|
|
1115 e 1334 also get reset. Look at rtn 'seldsk'
|
|
1116 e 1334 in 'initdira.a86' */
|
|
1117 e 1334 /*
|
|
1118 e 1334 if chkvecb = '1000000000000000'b then do;
|
|
1119 e 1334 if drive = 0 then drive = curdisk;
|
|
1120 e 1334 else drive = drive - 1;
|
|
1121 e 1334 checked = 0;
|
|
1122 e 1334 call reset();
|
|
1123 e 1334 errorcode = select(drive);
|
|
1124 e 1334 chkvecb = '1000000000000000'b;
|
|
1125 e 1334 errorcode = select(drive);
|
|
1126 e 1334 end;
|
|
1127 e 1334 */
|
|
1128 e 1334 call sysunlock(); /* unlock the disk system whf 1/83 */
|
|
1129 e 1337 dphp = seldsk(curdisk); /* restore drive */
|
|
1130 e 1341 call reset(); /* reset disk system */
|
|
1131 e 1344 errorcode = select(curdisk);
|
|
1132 e 134E call conunlock(); /* allow switching of consoles whf 1/83 */
|
|
1133 e 1351
|
|
1134 e 1351 call reboot;
|
|
1135 c 1355
|
|
1136 c 1355 end restore;
|
|
1137 e 1355
|
|
1138 e 1355 /* read logical record # to dma address */
|
|
1139 e 1355 read_sector: procedure(lrcd,dmaaddr) external;
|
|
1140 e 1355 dcl
|
|
1141 e 1363 lrcd bin fixed(15),
|
|
1142 e 1363 prcd decimal(7,0),
|
|
1143 e 1363 dmaaddr pointer; /* dma address */
|
|
1144 e 1363
|
|
1145 e 1363 prcd = lrcd/nfcbs1;
|
|
1146 e 137B gtrk = track(prcd);
|
|
1147 e 1385 call settrk(gtrk);
|
|
1148 e 138B gsec = sector(prcd);
|
|
1149 e 1395 call setsec(gsec);
|
|
1150 e 139B
|
|
1151 e 139B call bstdma(dmaaddr);
|
|
1152 e 13A7 if rdsec() ~= 0 then do;
|
|
1153 e 13B1 put skip list('While reading record ',prcd);
|
|
1154 e 13DF put list(': track ',gtrk,', sector',gsec);
|
|
1155 e 1419 call errprint(errXREAD);
|
|
1156 c 142B end;
|
|
1157 c 142B
|
|
1158 c 142B end read_sector;
|
|
1159 e 142B
|
|
1160 e 142B
|
|
1161 e 142B /* write logical record # from dma address */
|
|
1162 e 142B write_sector: procedure(lrcd,dmaaddr) external;
|
|
1163 e 142B dcl
|
|
1164 e 1439 lrcd bin fixed(15),
|
|
1165 e 1439 dmaaddr pointer, /* dma address */
|
|
1166 e 1439 prcd decimal(7,0);
|
|
1167 e 1439
|
|
1168 e 1439 prcd = lrcd/nfcbs1; /* #fcbs/phys rec */
|
|
1169 e 1451 gtrk = track(prcd);
|
|
1170 e 145B call settrk(gtrk);
|
|
1171 e 1461 gsec = sector(prcd);
|
|
1172 e 146B call setsec(gsec);
|
|
1173 e 1471
|
|
1174 e 1471 call bstdma(dmaaddr);
|
|
1175 e 147D if wrsec(1) ~= 0 then do;
|
|
1176 e 1487 put skip list('While writing record ',prcd);
|
|
1177 e 14B5 put list(': track ',gtrk,', sector',gsec);
|
|
1178 e 14EF call errprint(errXREAD);
|
|
1179 c 1501 end;
|
|
1180 c 1501
|
|
1181 c 1501
|
|
1182 c 1501 end write_sector;
|
|
1183 e 1501
|
|
1184 e 1501
|
|
1185 e 1501 /* select disk drive */
|
|
1186 e 1501 dselect: procedure((d)) external;
|
|
1187 e 1501 dcl
|
|
1188 e 1518 p ptr,
|
|
1189 e 1518 wdalv(16) fixed(15) based(p),
|
|
1190 e 1518 btalv(16) fixed(7) based(p),
|
|
1191 e 1518 all bit(16),
|
|
1192 e 1518 d fixed(7);
|
|
1193 e 1518
|
|
1194 e 1518
|
|
1195 e 1518 dcl
|
|
1196 e 1518 1 dpb based (dpbp),
|
|
1197 e 1518 2 sec bit(16),
|
|
1198 e 1518 2 bsh bit(8),
|
|
1199 e 1518 2 blm bit(8),
|
|
1200 e 1518 2 exm bit(8),
|
|
1201 e 1518 2 dsm bit(16),
|
|
1202 e 1518 2 drm bit(16),
|
|
1203 e 1518 2 al0 bit(8),
|
|
1204 e 1518 2 al1 bit(8),
|
|
1205 e 1518 2 cks bit(16),
|
|
1206 e 1518 2 off bit(8);
|
|
1207 e 1518
|
|
1208 e 1518 if d = 0 then d = curdsk();
|
|
1209 e 1527 else d = d - 1;
|
|
1210 e 152B
|
|
1211 e 152B errorcode = select(d); /* sync BIOS & BDOS */
|
|
1212 e 1535 dphp = seldsk(d);
|
|
1213 e 153F if dphp = null then call errprint(errBIOS);/* can't select disk */
|
|
1214 e 1561
|
|
1215 e 1561 xlt = xlt1;
|
|
1216 e 156A dpbp = dpbptr;
|
|
1217 e 1575
|
|
1218 e 1575 dspt = decimal(spt); /**** whf 1/8/83 ****/
|
|
1219 c 1587
|
|
1220 c 1587 end dselect;
|
|
1221 e 1587
|
|
1222 e 1587 /* convert logical rcd # to physical sector */
|
|
1223 e 1587 sector: procedure(i) returns(fixed(15)) external;
|
|
1224 e 1587 dcl
|
|
1225 e 158E i decimal(7,0);
|
|
1226 e 158E
|
|
1227 e 158E return(sectrn(binary(mod(i,dspt),15),xlt));
|
|
1228 c 15B2
|
|
1229 c 15B2 end sector;
|
|
1230 e 15B2
|
|
1231 e 15B2
|
|
1232 e 15B2 /* logical record # to physical track */
|
|
1233 e 15B2 track: procedure(i) returns(fixed(15)) external;
|
|
1234 e 15B2 dcl
|
|
1235 a 15B9 i decimal(7,0);
|
|
1236 a 15B9
|
|
1237 a 15B9 return(offset + binary(i/dspt,15));
|
|
1238 c 15E5
|
|
1239 c 15E5 end track;
|
|
1240 e 15E5
|
|
1241 e 15E5
|
|
1242 e 15E5 /* logical record # to physical block */
|
|
1243 e 15E5 conv: procedure(i) returns(fixed(15)) external;
|
|
1244 e 15E5 dcl
|
|
1245 e 15EC i fixed(7),
|
|
1246 e 15EC j fixed(15),
|
|
1247 e 15EC p ptr,
|
|
1248 e 15EC n fixed(7) based(p);
|
|
1249 e 15EC
|
|
1250 e 15EC p = addr(j);
|
|
1251 e 15F2 j = 0;
|
|
1252 e 15F8 n = i;
|
|
1253 e 1604 return(j);
|
|
1254 c 1609 end conv;
|
|
1255 e 1609
|
|
1256 e 1609 patch: procedure;
|
|
1257 e 1609 dcl i fixed(15);
|
|
1258 e 160C
|
|
1259 e 160C i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
|
1260 e 1634 i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
|
1261 e 165C i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
|
1262 e 1684 i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
|
1263 e 16AC i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
|
1264 e 16D4 i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
|
1265 e 16FC i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
|
1266 e 1724 i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
|
1267 c 174D end patch;
|
|
1268 a 174D
|
|
1269 a 174D
|
|
1270 a 174D
|
|
1271 a 174D end initdir;Code Size: 1750
|
|
Data Size: 3980
|
|
End of Compilation
|