/************************************************************** * This PL/I program tests CP/M operating system entry points. * * Note: The file DIOMOD.DCL contains only those declarations * * for the entry points common to both the 8080 and 8086 * * implementations. If you are running under CP/M 2.2 (or * * newer) you also need to include the file DIO80.DCL. If you * * are running under CP/M-86, you also need to include the * * file DIO86.DCL. * ***************************************************************/ diotest: procedure options(main); %include 'diomod.dcl'; /* and either 'dio80.dcl' or 'dio86.dcl' */ declare c character(1), v character(254) varying, i fixed; /********************************** * * * Fixed Location Tests: * * * * MEMPTR, MEMSIZ, MEMWDS, * * DFCB0, DFCB1, DBUFF * * * **********************************/ declare memptrv pointer, memsizv fixed, (dfcb0v, dfcb1v, dbuffv) pointer, command character(127) varying based (dbuffv), 1 fcb0 based(dfcb0v), 2 drive fixed(7), 2 name character(8), 2 type character(3), 2 extnt fixed(7), 2 space (19) bit(8), 2 cr fixed(7), memory (0:0) based(memptrv) bit(8); memptrv = memptr(); memsizv = memsiz(); dfcb0v = dfcb0(); dfcb1v = dfcb1(); dbuffv = dbuff(); put edit ('Command Tail: ',command) (a); put edit ('First Default File:', fcb0.name,'.',fcb0.type) (skip,4a); put edit ('dfcb0 ',unspec(dfcb0v), 'dfcb1 ',unspec(dfcb1v), 'dbuff ',unspec(dbuffv), 'memptr',unspec(memptrv), 'memsiz',unspec(memsizv), 'memwds',memwds()) (5(skip,a(7),b4),skip,a(7),f(6)); put skip list('Clearing Memory'); /* sample loop to clear memory */ do i = 0 repeat(i+1) while (i^=memsizv-1); memory (i) = '00'b4; end; /********************************** * * * REBOOT Test * * * **********************************/ put skip list ('Reboot? (Y/N)'); get list (c); if translate(c,'Y','y') = 'Y' then call reboot(); /********************************** * * * RDCON, WRCON Test * * * **********************************/ put list('Type Input, End with "$" '); v = '^m^j'; do while (substr(v,length(v)) ^= '$'); v = v || rdcon(); end; put skip list('You Typed:'); do i = 1 to length(v); call wrcon(substr(v,i,1)); end; /********************************** * * * RDRDR and WRPUN Test * * * **********************************/ put skip list('Reader to Punch Test?(Y/N)'); get list (c); if translate(c,'Y','y') = 'Y' then do; put skip list('Copying RDR to PUN until ctrl-z'); c = ' '; do while (c ^= '^z'); c = rdrdr(); if c ^= '^z' then call wrpun(c); end; end; /********************************** * * * WRLST Test * * * **********************************/ put list('List Output Test?(Y/N)'); get list(c); if translate(c,'Y','y') = 'Y' then do i = 1 to length(v); call wrlst(substr(v,i,1)); end; /********************************** * * * Direct I/O, CONOUT, CONINP * * * **********************************/ put list ('Direct I/O, Type Line, End with Line Feed'); c = ' '; do while (c ^= '^j'); call conout(c); c = coninp(); end; /********************************** * * * Direct I/O, Console Status * * RDSTAT * * * **********************************/ put skip list('Status Test, Type Character'); do while (^rdstat()); end; /* clear the character */ c = coninp(); /********************************** * * * GETIO, SETIO IObyte * * * **********************************/ declare iobyte bit(8); iobyte = getio(); put edit ('IObyte is ',iobyte,', New Value: ') (skip,a,b4,a); get edit (iobyte) (b4(2)); call setio(iobyte); /********************************** * * * Buffered Write, WRSTR Test * * * **********************************/ put list('Buffered Output Test:'); /* "v" was previously filled by RDCON */ call wrstr(addr(v)); /********************************** * * * Buffered Read RDBUF Test * * * **********************************/ declare 1 inbuff static, 2 maxsize bit(8) initial('80'b4), 2 inchars character(127) varying; put skip list('Line Input, Type Line, End With Return'); put skip; call rdbuf(addr(inbuff)); put skip list('You Typed: ',inchars); /********************************** * * * Console BREAK Test * * * **********************************/ put skip list('Console Break Test, Type Character'); do while(^break()); end; c = rdcon(); /********************************** * * * Version Number VERS Test * * * **********************************/ declare version bit(16); version = vers(); if substr(version,1,8) = '00'b4 then put skip list('CP/M'); else put skip list('MP/M'); put edit(' Version ',substr(version,9,4),'.',substr(version,13,4)) (a,b4,a,b4); /********************************** * * * Disk System RESET Test * * * **********************************/ put skip list('Resetting Disk System'); call reset(); /********************************** * * * Disk SELECT Test * * * **********************************/ put skip list('Select Disk # '); get list(i); call select(i); /********************************** * * * Note: The OPEN, CLOSE, SEAR, * * SEARN, DELETE, RDSEQ, * * WRSEQ, MAKE, and RENAME * * functions are tested in * * the DIOCOPY program. * * * **********************************/ /********************************** * * * LOGVEC and CURDSK * * * **********************************/ put skip list ('Login Vector',logvec(), 'Current Disk',curdsk()); /********************************** * * * See DIOCOPY for SETDMA Function * * * **********************************/ /********************************** * * * Allocate Vector ALLVEC Test * * * * Note: This test contains two * * different versions; one for * * 8080 code, and another for * * 8086 code. Before compiling * * you must comment out the * * version you don't want to use. * * * **********************************/ /* 8080 version declare alloc (0:30) bit(8) based (allvec()), allvecp pointer; allvecp = allvec(); put edit('Alloc Vector at ',unspec(allvecp),':', (alloc(i) do i=0 to 30)) (skip,a,b4,a,254(skip,4(b,x(1)))); */ /* 8086 version declare alloc (0:30) bit(8), allvecp(2) pointer; call allvec(allvecp); call movgtl(31,allvecp,addr(alloc)); put edit('Alloc Vector at offset ', unspec(allvecp(1)), ', segment ',unspec(allvecp(2)),':', (alloc(i) do i=0 to 30)) (skip,a,b4,a,b4,a,254(skip,4(b,x(1)))); */ /********************************** * * * Note: the following functions * * apply to version 2.0 or newer. * * * **********************************/ /********************************** * * * WPDISK Test * * * **********************************/ put skip list('Write Protect Disk?(Y/N)'); get list(c); if translate(c,'Y','y') = 'Y' then call wpdisk(); /********************************** * * * ROVEC Test * * * **********************************/ put skip list('Read/Only Vector is',rovec()); /********************************** * * * Disk Parameter Block Decoding * * Using GETDPB * * * * Note: This test contains two * * different versions; one for * * 8080 code, and another for * * 8086 code. Before compiling * * you must comment out the * * version you don't want to use. * * * **********************************/ /* 8080 version declare dpbp pointer, 1 dpb based (dpbp), 2 spt fixed(15), 2 bsh fixed(7), 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 fixed(15); dpbp = getdpb(); put edit('Disk Parameter Block:', 'spt',spt,'bsh',bsh,'blm',blm, 'exm',exm,'dsm',dsm,'drm',drm, 'al0',al0,'al1',al1,'cks',cks, 'off',off) (skip,a,2(skip,a(4),f(6)),4(skip,a(4),b4), skip,2(a(4),b,x(1)),skip,a(4),b4, skip,a(4),f(6)); */ /* 8086 version declare dpbp(2) pointer, 1 dpb, 2 spt fixed(15), 2 bsh fixed(7), 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 fixed(15); call getdpb(dpbp); call movgtl(15,dpbp,addr(dpb)); put edit('Disk Parameter Block:', 'spt',spt,'bsh',bsh,'blm',blm, 'exm',exm,'dsm',dsm,'drm',drm, 'al0',al0,'al1',al1,'cks',cks, 'off',off) (skip,a,2(skip,a(4),f(6)), 4(skip,a(4),b4), skip,2(a(4),b,x(1)), skip,a(4),b4, skip,a(4),f(6)); */ /********************************** * * * Test Get/Set user Code * * GETUSR, SETUSR * * * **********************************/ put skip list ('User is',getusr(),', New User:'); get list(i); call setusr(i); /********************************** * * * FILSIZ, SETREC, * * RDRAN, WRRAN, WRRANZ are * * tested in DIORAND * * * **********************************/ /********************************** * * * Test Drive Reset RESDRV * * (version 2.2 or newer) * * * **********************************/ declare drvect bit(16); put list('Drive Reset Vector:'); get list(drvect); call resdrv(drvect); /********************************** * * * * **********************************/ end diotest;