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
