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