initdir: procedure options(main); declare cpm3 char(2) static initial('30'); /* fixed bug in clearout, buildnew, and reconstruction 11/12/82 */ /* copyright(c) 1982 digital research box 579 pacific grove, ca 93950 */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * DISK INTERFACE * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ %include 'diomod.dcl'; %include 'plibios.dcl'; %replace TRUE by '1'b, FALSE by '0'b; /* directory array 4K */ declare 1 dir_fcb(0:127), 3 user bit(8), 3 rest(31) char(1), 1 outbuf(0:127), 2 user fixed(7), 2 rest(31) char(1), 1 buffer2(0:127), 2 user bit(8), 2 rest(31) bit(8), 1 outb(0:127) based(outptr), 2 rest char(32), 1 outb2(0:127) based(outptr), 2 user bit(8), 2 rest(31) char(1), 1 outb3(0:127) based(outptr), 2 user fixed(7), 2 rest(31) bit(8), 1 outb4(0:127) based(outptr), 2 sfcbm char(1), 2 sfcb(3), 3 stamps char(8), 3 mode bit(8), 3 rest char(1), 2 frest char(1), 1 infcb(0:127) based(dirptr), 2 rest char(32), 1 infcb2(0:127) based(dirptr), 2 user char(1), 2 name char(11), 2 pmode bit(8), 2 junk1 char(11), 2 stamp char(8), 1 clearbuf(0:127) based(clearptr), 2 rest char(32), zeroes(31) bit(8) static init((31)'00000000'b); /* directory array mask */ declare 1 dirm(0:127) based(dirptr), 3 user fixed(7), 3 fname char(8), 3 ftype char(3), 3 fext bin fixed(7), 3 fs1 bit(8), 3 fs2 bit(8), 3 frc fixed(7), 3 diskpass(8) char(1), 3 rest char(8); declare /* disk parameter header mask */ dphp ptr, 1 dph_mask based(dphp), 2 xlt1 ptr, 2 space(9) bit(8), 2 mediaf bit(8), 2 dpbptr ptr, 2 csvptr ptr, 2 alvptr ptr, 2 dirbcb ptr, 2 dtabcb ptr, 2 hash ptr, 2 hbank ptr, xlt ptr; /* save the xlt ptr because of F10 buffer */ declare /* disk parameter block mask */ dpbp ptr ext, 1 dpb_mask based(dpbp), 2 spt fixed(15), 2 blkshft fixed(7), 2 blkmsk fixed(7), 2 extmsk fixed(7), 2 dsksiz fixed(15), 2 dirmax fixed(15), 2 diralv bit(16), 2 checked fixed(15), 2 offset fixed(15), 2 physhf fixed(7), 2 phymsk fixed(7), dspt decimal(7,0), dblk decimal(7,0); declare dir_blks(32) bit(8), errorcode bit(16); declare MAXSAVE bin fixed(15), enddcnt bin fixed(15), nxfcb bin fixed(15), notsaved bin fixed(15), xptr pointer, 1 XFCBs(1) based(xptr), 2 user bin fixed(7), 2 name char(11), 2 pmode bit(8), 2 stamp char(8); declare INITMSG char(54) static initial ('INITDIR WILL ACTIVATE TIME STAMPS FOR SPECIFIED DRIVE.'), CONFIRM char(60) varying static initial ('Do you want to re-format the directory on drive: '), ASKCLEAR char(44) static initial ('Do you want the existing time stamps cleared'), RECOVER char(50) varying static init ('Do you want to recover time/date directory space'), YN char(10) static initial(' (Y/N)? '), YES char(1) static initial('Y'), lyes char(1) static initial('y'), yesno char(1), UPPERCASE char(26) static initial ('ABCDEFGHIJKLMNOPQRSTUVWXYZ'), LOWERCASE char(26) static initial ('abcdefghijklmnopqrstuvwxyz'), pass1 char(20) static initial ('End of PASS 1.'), ERRORM char(7) static initial('ERROR: '), TERM char(30) static initial('INITDIR TERMINATED.'), errvers char(30) static initial ('Requires CP/M 3.0 or higher.'), errnotnew char(31) static initial ('Directory already re-formatted.'), errtoobig char(30) static initial ('Not enough room in directory.'), errpass char(15) static initial('Wrong password.'), errSTRIP char(30) varying static initial ('No time stamps present.'), errMEM char(30) varying static initial ('Not enough available memory.'), errRO char(20) varying static initial ('Disk is READ ONLY.'), errWHAT char(30) varying static initial ('Cannot find last XFCB.'), errRSX char(60) varying static initial ('Cannot re-format the directory with RSXs in memory.'), errunrec char(19) static initial ('Unrecognized drive.'), errBIOS char(20) static initial('Cannot select drive.'); declare outptr pointer, bufptr1 pointer, bufptr2 pointer, dirptr pointer, drivptr pointer, clearptr pointer, nempty bin fixed(15), (nfcbs,nfcbs1) bin fixed(15), lastsfcb bin fixed(15), lastdcnt bin fixed(15), (lasti,lastx) bin fixed(15), lastsect bin fixed(15), cleardcnt bin fixed(15), (gsec,gtrk) bin fixed(15), (dcnt,sect) bin fixed(15), outdcnt bin fixed(15), newdcnt bin fixed(15), outidx bin fixed(7), curdisk bin fixed(7), newlasti bin fixed(7), (sfcbidx,sfcboffs) bin fixed(15), usernum fixed(7), SFCBmark fixed(7) static initial(33), Dlabel bin fixed(7) static initial (32), Redo bit(1), bad bit(1), writeflag bit(1), CLEARSECT bit(1), CLEARSFCB bit(1), labdone bit(1) static initial(false), cversion bit(16), READonly bit(16), ptreos pointer, EOS bit(8) static initial('00'b4), CEOS char(1) based (ptreos), fcb(32) char(1), fcb0(50) char(1) based (drivptr), dr0 fixed(7) based(drivptr), disks char(16) static initial ('ABCDEFGHIJKLMNOP'), drive bin fixed(7), cdrive char(1); declare 1 SCB, 2 soffs fixed(7), 2 seter fixed(7), 2 value char(2), ccppage bit(8); /************************************************************************* *** MAIN PROGRAM *** **************************************************************************/ declare i bin fixed(7); cversion = vers(); if substr(cversion,9,8) < '31'b4 then call errprint((errvers)); soffs = 23; seter = 0; ccppage = sgscb(addr(SCB)); /* if RSX present then stop */ if substr(ccppage,7,1) = '1'b then call errprint(errRSX); drivptr = dfcb0(); /* get drive */ drive = dr0; if dr0 > 16 then drive = 0; do while(drive = 0); /* none recognized */ call wrongdisk(i,drive); call getdisk(i,drive); end; cdrive = substr(disks,drive,1); curdisk = curdsk(); /* restore BIOS to this */ put edit(INITMSG,confirm,cdrive,YN)(skip(2),a,skip,a,a,a); get list(yesno); if yesno ~= YES & yesno ~= lyes then call reboot; READonly = rovec(); /* is the drive RO ? */ if substr(READonly,(17-drive),1) = '1'b then call errprint(errRO); call dselect(drive); nfcbs = ((phymsk + 1)*4) - 1; /* # fcbs/physical rcd - 1 */ nfcbs1 = nfcbs + 1; dirptr = addr(dir_fcb(0)); dcnt = 0; call read_sector(dcnt,dirptr); call init; call restore; /********************************************************************/ wrongdisk: procedure(i,drive); declare (i,j,drive) bin fixed(7); put list(ERRORM,errunrec); put skip list('DRIVE: '); /* print errant string */ j = i; ptreos = addr(EOS); do while(fcb0(j) ~= ' ' & fcb0(j) ~= CEOS); put edit(fcb0(j))(a); j = j + 1; end; put skip; end wrongdisk; getdisk: procedure(i,drive); declare (i,drive) bin fixed(7); put skip list('Enter Drive: '); get list(fcb0(i)); fcb0(i) = translate(fcb0(i),UPPERCASE,LOWERCASE); fcb0(i+1) = ':'; drive = index(disks,fcb0(i)); end getdisk; /**************************************************************************/ init: procedure; declare (i,j,k,l) bin fixed(15); call allxfcb; /* allocate XFCB data space */ call countdir; lastx = nxfcb; sect = sect - 1; dcnt = dcnt - 1; /* reset to good dcnt */ if Redo then do; newdcnt = lastdcnt; newlasti = lasti; end; else do; newdcnt = lastdcnt + lastsfcb + (2 - mod(lastdcnt,3)); if (newdcnt + 1) > dirmax then do; lastdcnt = lastdcnt - nempty; lastsfcb = lastdcnt/3 + 1; newdcnt = lastdcnt + lastsfcb + (2 - mod(lastdcnt,3)); if (newdcnt + 1) > dirmax then call errprint(errtoobig); call collapse; /* remove all empties by collapsing dir from top */ lastsfcb = lastdcnt/3 + 1; newdcnt = lastdcnt + lastsfcb + (2 - mod(lastdcnt,3)); end; newlasti = mod(newdcnt,nfcbs1) - 3 + mod(lastdcnt,3); end; outptr = addr(buffer2(0)); /* want to clear last read sector...buffer2 only used in collapse so it is free */ call clearout; clearptr = outptr; outptr = addr(outbuf(0)); call clearout; /* zero output buffer */ /***********************************************************************/ do while(lastsect < sect ); /* clear from end of dir */ call write_sector(dcnt,outptr); dcnt = dcnt - nfcbs1; sect = sect - 1; end; if (nempty - 1) ~= dirmax then do; /* if there are files on dir */ /* bottom of directory is now all E5 and 21... it is positioned to the last good sector of the old directory. */ dcnt = lastdcnt; enddcnt = newdcnt; call read_sector(dcnt,dirptr); /* read last good sector */ outidx = newlasti; /* index into out buffer */ call buildnew(lasti); /* fill in outbuff from the bottom up...need this call because lasti may be in middle of read buffer */ do while(dcnt >= 0); /* as soon as we are finished with reading old sector, then go clear it. This should limit possibility that duplicate FCB's occur. */ call read_sector(dcnt,dirptr); call buildnew(nfcbs); end; end; /* virgin dir */ else call write_sector(0,outptr); /* write last sector */ do while(notsaved > 0); call moreXFCB; end; end init; /************************************************************************/ strip: procedure; /* remove all SFCB from directory by jamming E5 into user field. Also turn off time/date stamping in DIR LABEL. */ declare (i,j) bin fixed(7), 1 direct(0:127) based(dirptr), 2 junk1 char(12), 2 ext bit(8), 2 rest char(19), olddcnt bin fixed(15); dcnt = 0; do while(dcnt <= dirmax); call read_sector(dcnt,dirptr); olddcnt = dcnt; do i = 0 to nfcbs while(dcnt <= dirmax); if ~labdone then if dirm(i).user = Dlabel then do; call getpass(i); direct(i).ext = direct(i).ext & '10000001'b; labdone = true; end; if dirm(i).user = SFCBmark then dir_fcb(i).user = 'E5'b4; dcnt = dcnt + 1; end; call write_sector(olddcnt,dirptr); end; end strip; /*****************************************************************************/ countdir: procedure; declare i bin fixed(7); /* there are 5 valid sets of codes in the user field: E5 - empty 0-15 - user numbers 32 - Directory label 33 - SFCB marker 16-31 - XFCB marker This routine counts the # of used directory slots ignoring E5. NOTE: if SFCB present then last slot = SFCB */ Redo = false; nempty = 0; sect = 0; nxfcb = 0; notsaved = 0; bad = true; /* If dir is already time stamped then SFCBs should appear in every sector, notably the first sector. Thus, test first sector. If first sector has SFCB then all do. If none in first & they appear later then INITDIR was probably interrupted. In that case, zap the found SFCB's and treat dir as virgin. */ if dirm(3).user = SFCBmark then bad = false; do while(dcnt <= dirmax); do i = 0 to nfcbs while(dcnt <= dirmax); if dir_fcb(i).user ~= 'E5'b4 then do; usernum = dirm(i).user; if ~Redo & usernum = 33 then call query; if usernum > 15 & usernum < 32 then call getXFCB(i); /* if LABEL then check for password... may terminate in getpass */ else if usernum = Dlabel then call getpass(i); if (usernum < 33) | (~bad & usernum = 33) then do; lasti = i; lastsect = sect; lastdcnt = dcnt; end; /* bad...*/ else if usernum = 33 then nempty = nempty + 1; end; /* E5 ... */ else nempty = nempty + 1; dcnt = dcnt + 1; end; sect = sect + 1; call read_sector(dcnt,dirptr); end; if ~Redo then lastsfcb = lastdcnt/3 + 1; end countdir; getXFCB: procedure(i); declare i bin fixed(7); if nxfcb <= MAXSAVE then do; nxfcb = nxfcb + 1; XFCBs(nxfcb).user = usernum - 16; XFCBs(nxfcb).name = infcb2(i).name; XFCBs(nxfcb).pmode = infcb2(i).pmode; XFCBs(nxfcb).stamp = infcb2(i).stamp; end; else notsaved = notsaved + 1; end getXFCB; allxfcb: procedure; /* allocates largest available block of space to be used in storing XFCB info. maxwds & allwds use word units */ declare maxwds entry returns(fixed(15)), allwds entry(fixed(15)) returns(pointer), size bin fixed(15); size = maxwds(); /* get largest block in free space */ if size <= 10 then call errprint(errMEM); xptr = allwds(size); /* reserve it */ MAXSAVE = (2*size)/21; /* # XFCBs that can be saved */ end allxfcb; query: procedure; if bad then return; put skip(2) list(errnotnew); /* check to see if user wants to strip SFCB's */ if ~asker(RECOVER) then do; Redo = true; CLEARSFCB = false; if asker(ASKCLEAR) then do; CLEARSFCB = true; return; end; end; else call strip; /* this will end down here after stripping */ call restore; /* dir is already formattted & user does not want to clear old SFCB's....just stop */ end query; buildnew: procedure(endidx); declare (i,j,k,endidx) bin fixed(15); declare 1 ot(0:127) based(outptr), 2 user fixed(7), 2 fname char(8), 2 ftype char(3), 2 rest char(20); /* build output buffer from input(end) to input(0). k => refers to input */ k = endidx; do while(k >= 0); usernum = dirm(k).user; outb(outidx).rest = infcb(k).rest; if usernum = SFCBmark then do; if bad then outb2(outidx).user = 'E5'b4; else if CLEARSFCB then outb3(outidx).rest = zeroes; end; if usernum < 16 then do; if nxfcb > 0 then /* if fcb is ex=0 and XFCB exists then check for possible SFCB update */ call putXFCB(k); end; if ~Redo & mod(outidx,4) = 0 then outidx = outidx - 2; else outidx = outidx - 1; k = k - 1; dcnt = dcnt - 1; if outidx < 0 then do; if dcnt > 14 then if mod(dcnt + 1,nfcbs1) = 0 then call write_sector(dcnt + 1,clearptr); call write_sector(newdcnt,outptr); newdcnt = newdcnt - nfcbs1; outidx = nfcbs - 1; if Redo then outidx = outidx + 1; end; end; end buildnew; /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ compare: procedure(k) returns(fixed(7)); declare (i,j,k) bin fixed(7), 1 direc(0:127) based(dirptr), 2 user fixed(7), 2 name(11) char(1), 2 rest char(20), 1 XFCB2(1) based(xptr), 2 user char(1), 2 name(11) char(1), 2 rest char(9); /* compare fcb with XFCB list; return position in list if found, 0 otherwise. Nullify usernum field in XFCB list (=99) if found. Decrement #xfcb as well.*/ do i = 1 to nxfcb; if XFCBs(i).user ~= 99 then do; if XFCBs(i).user = direc(k).user then do; do j = 1 to 11; if direc(k).name(j) ~= XFCB2(i).name(j) then go to outx; end; /* found a match */ XFCBs(i).user = 99; nxfcb = nxfcb - 1; return(i); outx: end; end; end; return(0); end compare; moreXFCB: procedure; /* we could not store all the xfcb's in memory available, so now must make another pass & store as many XFCB as possible. 'notsaved' > 0 ==> we may have to do this again. */ declare (i,k) bin fixed(7); dcnt = enddcnt; /* go to end of directory */ if ~findXFCB(k) then /* work backwards trying to find last known XFCB...if not found then something very strange has happened; call errprint(errWHAT); notsaved = 0; /* now in last sector where last XFCB occurs...look for other XFCB that we know is there. */ nxfcb = 0; dcnt = dcnt + 1; lastdcnt = dcnt; /* save position of last XFCB + 1 */ lasti = k + 1; /* index in sector */ do while(dcnt <= enddcnt); do i = k+1 to nfcbs while(dcnt <= enddcnt); usernum = dirm(i).user; if usernum > 15 & usernum < 32 then call getXFCB(i); dcnt = dcnt + 1; end; k = 0; call read_sector(dcnt,dirptr); end; dcnt = 0; /* go to start of dir */ do while(dcnt <= enddcnt); call read_sector(dcnt,dirptr); outdcnt = dcnt; writeflag = false; /* putXFCB sets when it finds a match */ do k = 0 to nfcbs while(dcnt <= enddcnt); outidx = k; if dirm(k).user < 16 then call putXFCB(k); dcnt = dcnt + 1; end; if writeflag then call write_sector(outdcnt,dirptr); end; end moreXFCB; findXFCB: procedure(idx) returns(bit(1)); /* find the last known XFCB...starts from the last written sector in the dir and goes backwards...hopefully that's faster */ declare idx fixed(7); do while(dcnt > 0); call read_sector(dcnt,dirptr); do idx = 0 to nfcbs while(dcnt > 0); usernum = dirm(idx).user; if usernum > 15 & usernum < 32 then if XFCBs(lastx).name = infcb2(idx).name then return(true); dcnt = dcnt + 1; end; end; return(false); /* big trouble...*/ end findXFCB; putXFCB: procedure(k); /* if this is extent 0 fold and names match then update SFCB from XFCB */ declare (k,j) fixed(7); if dirm(k).fext <= dpb_mask.extmsk then do; j = compare(k); if j ~= 0 then do; /* fcb matches XFCB... update the SFCB */ sfcboffs = mod(outidx+1,4); sfcbidx = outidx + (4 - sfcboffs); outb4(sfcbidx).sfcb(sfcboffs).stamps = XFCBs(j).stamp; outb4(sfcbidx).sfcb(sfcboffs).mode = XFCBs(j).pmode; writeflag = true; end; end; /* extent 0 ? */ end putXFCB; errprint: procedure(msg); declare msg char(60) varying; put edit(ERRORM,msg,TERM)(skip(2),a,a,skip,a); put skip(2); call restore; end errprint; asker: procedure(msg) returns(bit(1)); declare msg char(60) varying; put skip list(msg,YN); get list(yesno); if yesno ~= YES & yesno ~= lyes then return(false); return(true); end asker; clearout: procedure; declare (i,j) bin fixed(7); do i = 0 to nfcbs; if mod(i+1,4) ~= 0 then outb2(i).user = 'E5'b4; else outb3(i).user = SFCBmark; do j = 1 to 31; outb3(i).rest(j) = '00000000'b; end; end; end clearout; getpass: procedure(fcbx); /* Drive may be password protected... Get passw from user and compare with Password in label. Label password is encoded by first reversing each char nibble and then XOR'ing with the sum of the pass. S2 in label = that sum. */ declare passwd(8) bit(8) based(passptr), passptr pointer, convptr pointer, pchar(8) bit(8), cvpass(8) char(1) based(convptr), inpass char(8), (i,j,fcbx) bin fixed(7); labdone = true; passptr = addr(dirm(fcbx).diskpass); convptr = addr(pchar(1)); do i = 1 to 8; /* XOR each character */ pchar(i) = bool(passwd(i),dirm(fcbx).fs1,'0110'b); end; if cvpass(8) <= ' ' then return; /* no password */ put skip(2) list('Directory is password protected.'); put skip list('Password, please. >'); get list(inpass); inpass = translate(inpass,UPPERCASE,LOWERCASE); j = 8; do i = 1 to 8; if substr(inpass,i,1) ~= cvpass(j) then call errprint(errpass); j = j - 1; end; end getpass; collapse: procedure; declare whichbuf bin fixed(7), enddcnt bin fixed(15), (i,nout1,nout2) bin fixed(7); dcnt = 0; sect = 0; outdcnt = 0; whichbuf = 0; nout1 = 0; nout2 = 0; lastsect = 0; enddcnt = lastdcnt + nempty; lastdcnt = 0; bufptr1 = addr(outbuf(0)); bufptr2 = addr(buffer2(0)); do while(dcnt <= enddcnt); /* read up to last dcnt */ call read_sector(dcnt,dirptr); do i = 0 to nfcbs while(dcnt <= enddcnt); if dir_fcb(i).user ~= 'E5'b4 & dirm(i).user ~= SFCBmark then do; if whichbuf = 0 then call fill(bufptr1,i,nout1,whichbuf); else call fill(bufptr2,i,nout2,whichbuf); end; dcnt = dcnt + 1; end; sect = sect + 1; if nout1 = nfcbs1 then call flush_write(nout1,bufptr1); else if nout2 = nfcbs1 then call flush_write(nout2,bufptr2); end; dcnt = dcnt - 1; /* fill unused slots in buffer with empty...scratch rest of dir */ if whichbuf = 0 then call fill2(bufptr1,nout1); else call fill2(bufptr2,nout2); end collapse; fill: proc(bufptr,i,nout,whichbuf); declare bufptr pointer, (i,j,nout) bin fixed(7), whichbuf bin fixed(7), 1 buffer(0:127) based(bufptr), 2 out char(32); buffer(nout).out = infcb(i).rest; lastdcnt = lastdcnt + 1; nout = nout + 1; if nout = nfcbs1 then whichbuf = mod((whichbuf + 1),2); end fill; flush_write: proc(nout,bufptr); declare nout bin fixed(7), bufptr pointer; /* always behind the read...thus don't need to test to see if read sector = write sector. */ call write_sector(outdcnt,bufptr); outdcnt = outdcnt + nfcbs1; nout = 0; lastsect = lastsect + 1; end flush_write; fill2: proc(bufptr,nout); declare (i,j,nout) bin fixed(7), bufptr pointer, 1 buffer(0:127) based(bufptr), 2 user bit(8), 2 rest(31) bit(8); do i = nout to nfcbs; buffer(i).user = 'E5'b4; do j = 1 to 31; buffer(i).rest(j) = '00000000'b; end; end; lastdcnt = lastdcnt - 1; lasti = nout - 1; call flush_write(nout,bufptr); do i = 0 to nfcbs; /* prepare empty sector */ buffer(i).user = 'E5'b4; do j = 1 to 31; buffer(i).rest(j) = '00000000'b; end; end; /* clear rest of directory */ do while (outdcnt < dcnt); call write_sector(outdcnt,bufptr); outdcnt = outdcnt + nfcbs1; end; end fill2; restore: procedure; dphp = seldsk(curdisk); /* restore drive */ call reset(); /* reset disk system */ errorcode = select(curdisk); call reboot; end restore; /* read logical record # to dma address */ read_sector: procedure(lrcd,dmaaddr); dcl lrcd bin fixed(15), prcd decimal(7,0), dmaaddr pointer; /* dma address */ prcd = lrcd/nfcbs1; gtrk = track(prcd); call settrk(gtrk); gsec = sector(prcd); call setsec(gsec); call bstdma(dmaaddr); if rdsec() ~= 0 then signal error(71); end read_sector; /* write logical record # from dma address */ write_sector: procedure(lrcd,dmaaddr); dcl lrcd bin fixed(15), dmaaddr pointer, /* dma address */ prcd decimal(7,0); prcd = lrcd/nfcbs1; /* #fcbs/phys rec */ gtrk = track(prcd); call settrk(gtrk); gsec = sector(prcd); call setsec(gsec); call bstdma(dmaaddr); if wrsec(1) ~= 0 then signal error(91); end write_sector; /* select disk drive */ dselect: procedure((d)); dcl p ptr, wdalv(16) fixed(15) based(p), btalv(16) fixed(7) based(p), all bit(16), d fixed(7); dcl 1 dpb based (dpbp), 2 sec bit(16), 2 bsh bit(8), 2 blm bit(8), 2 exm bit(8), 2 dsm bit(16), 2 drm bit(16), 2 al0 bit(8), 2 al1 bit(8), 2 cks bit(16), 2 off bit(8); if d = 0 then d = curdsk(); else d = d - 1; errorcode = select(d); /* sync BIOS & BDOS */ dphp = seldsk(d); if dphp = null then call errprint(errBIOS);/* can't select disk */ xlt = xlt1; dpbp = dpbptr; dspt = decimal(spt/(phymsk + 1)); dblk = decimal(conv(blkmsk) + 1); /* get directory blocks */ p = addr(dir_blks(1)); all = al0; substr(all,9) = al1; do d = 1 to 16; wdalv(d) = 0; /* clears dir_blks to 0s */ if substr(all,d,1) then if dsksiz < 255 then btalv(d) = d - 1; else wdalv(d) = d - 1; end; end dselect; /* convert logical rcd # to physical sector */ sector: procedure(i) returns(fixed(15)); dcl i decimal(7,0); return(sectrn(binary(mod(i,dspt),15),xlt)); end sector; /* logical record # to physical track */ track: procedure(i) returns(fixed(15)); dcl i decimal(7,0); return(offset + binary(i/dspt,15)); end track; /* logical record # to physical block */ block: procedure(i) returns(fixed(15)); dcl i decimal(7,0); return(binary(i/dblk,15)); end block; /* block to logical sector */ bsec: procedure(i) returns(decimal(7,0)); dcl i fixed(15); if i > dsksiz then signal error(83); return(decimal(i) * dblk); end bsec; /* convert fixed(7) to fixed(15) w/o sign extension */ conv: procedure(i) returns(fixed(15)); dcl i fixed(7), j fixed(15), p ptr, n fixed(7) based(p); p = addr(j); j = 0; n = i; return(j); end conv; /* test for console break */ break_test: procedure ext; if con_break() then signal error(85); end break_test; /* test for console break */ con_break: procedure returns(bit(1)); dcl c char(1); if break() then do; c = rdcon(); if c ~= '^S' then return(TRUE); end; return(FALSE); end con_break; end initdir;