APPENDIX D

LISTING OF "DIORAND"
SHOWING EXTENDED RANDOM ACCESS CALLS



PL/I-80 V1.0, COMPILATION OF: DIORAND

L: List Source Program

%include 'diomod.dcl';
%include 'fcb.dcl';
   NO ERROR(S) IN PASS 1

   NO ERROR(S) IN PASS 2

PL/I-80 V1.0, COMPILATION OF: DIORAND

   1 a 0000 diorand:
   2 a 0006     proc options(main);
   3 a 0006     /* random access tests for 2.0 and 2.2 */
   4 a 0006 
   5+c 0006     dcl
   6+c 0006         memptr entry         returns (ptr),
   7+c 0006         memsiz entry         returns (fixed(15)),
   8+c 0006         memwds entry         returns (fixed(15)),
   9+c 0006         dfcb0  entry         returns (ptr),
  10+c 0006         dfcb1  entry         returns (ptr),
  11+c 0006         dbuff  entry         returns (ptr),
  12+c 0006         reboot entry,
  13+c 0006         rdcon  entry         returns (char(1)),
  14+c 0006         wrcon  entry         (char(1)),
  15+c 0006         rdrdr  entry         returns (char(1)),
  16+c 0006         wrpun  entry         (char(1)),
  17+c 0006         wrlst  entry         (char(1)),
  18+c 0006         coninp entry         returns (char(1)),
  19+c 0006         conout entry         (char(1)),
  20+c 0006         rdstat entry         returns (bit(1)),
  21+c 0006         getio  entry         returns (bit(8)),
  22+c 0006         setio  entry         (bit(8)),
  23+c 0006         wrstr  entry         (ptr),
  24+c 0006         rdbuf  entry         (ptr),
  25+c 0006         break  entry         returns (bit(1)),
  26+c 0006         vers   entry         returns (bit(16)),
  27+c 0006         reset  entry,
  28+c 0006         select entry         (fixed(7)),
  29+c 0006         open   entry   (ptr) returns (fixed(7)),
  30+c 0006         close  entry   (ptr) returns (fixed(7)),
  31+c 0006         sear   entry   (ptr) returns (fixed(7)),
  32+c 0006         searn  entry         returns (fixed(7)),
  33+c 0006         delete entry   (ptr),
  34+c 0006         rdseq  entry   (ptr) returns (fixed(7)),
  35+c 0006         wrseq  entry   (ptr) returns (fixed(7)),
  36+c 0006         make   entry   (ptr) returns (fixed(7)),
  37+c 0006         rename entry   (ptr),
  38+c 0006         logvec entry         returns (bit(16)),
  39+c 0006         curdsk entry         returns (fixed(7)),
  40+c 0006         setdma entry         (ptr),
  41+c 0006         allvec entry         returns (ptr),
  42+c 0006         wpdisk entry,
  43+c 0006         rovec  entry         returns (bit(16)),
  44+c 0006         filatt entry         (ptr),
  45+c 0006         getdpb entry         returns (ptr),
  46+c 0006         getusr entry         returns (fixed(7)),
  47+c 0006         setusr entry   (fixed(7)),
  48+c 0006         rdran  entry   (ptr) returns (fixed(7)),
  49+c 0006         wrran  entry   (ptr) returns (fixed(7)),
  50+c 0006         filsiz entry   (ptr),
  51+c 0006         setrec entry   (ptr),
  52+c 0006         resdrv entry         (bit(16)),
  53+c 0006         wrranz entry   (ptr) returns (fixed(7));
  54 c 0006 
  55 c 0006     dcl
  56 c 0006         1 database,
  57+c 0006           2 name1,
  58+c 0006             3 drive fixed(7),  /* drive number */
  59+c 0006             3 fname char(8),   /* file name */
  60+c 0006             3 ftype char(3),   /* file type */
  61+c 0006             3 fext  fixed(7),  /* file extent */
  62+c 0006             3 space (3) bit(8),/* filler */
  63+c 0006           2 name2,             /* used in rename */
  64+c 0006             3 drive2 fixed(7),
  65+c 0006             3 fname2 char(8),
  66+c 0006             3 ftype2 char(3),
  67+c 0006             3 fext2  fixed(7),
  68+c 0006             3 space2 (3) bit(8),
  69+c 0006           2 crec  fixed(7),    /* current record */
  70+c 0006           2 rrec  fixed(15),   /* random record */
  71+c 0006           2 rovf  fixed(7);    /* random rec overflow */
  72 c 0006 
  73 c 0006     dcl
  74 c 0006         lower char(26) static initial
  75 c 0006         ('abcdefghijklmnopqrstuvwxyz'),
  76 c 0006         upper char(26) static initial
  77 c 0006         ('ABCDEFGHIJKLMNOPQRSTUVWXYZ');
  78 c 0006 
  79 c 0006     dcl
  80 c 0006         /* simple variables */
  81 c 0006         i        fixed,
  82 c 0006         fn       char(20),
  83 c 0006         c        char(1),
  84 c 0006         code     fixed(7),
  85 c 0006         mode     fixed(2),
  86 c 0006         zerofill bit(1),
  87 c 0006         version  bit(16);
  88 c 0006 
  89 c 0006     dcl
  90 c 0006         /* overlays on default buffer */
  91 c 0006         bitbuf (128) bit(8)  based(dbuff()),
  92 c 0006         buffer char(127) var based(dbuff());
  93 c 0006 
  94 c 0006     put skip list('Random Access Test');
  95 c 0022     /* check version number for 2.0 */
  96 c 0022     version = vers();
  97 c 0028     if substr(version,9,8) < '20'b4 then
  98 c 0031         do;
  99 c 0031         put skip list('You Need Version 2');
 100 c 004D         stop;
 101 c 0050         end;
 102 c 0050     put skip list('Zero Record Fill?');
 103 c 006C     get list(c);
 104 c 0086     zerofill = (c = 'Y' ! c = 'y') &
 105 c 00B5         substr(version,9,8) >= '22'b4;
 106 c 00B5 
 107 c 00B5     /* read and process file name */
 108 c 00B5     put skip list('Data Base Name: ');
 109 c 00D1     get list(fn);
 110 c 00EB     fn = translate(fn,upper,lower);
 111 c 0110 
 112 c 0110     /* process optional drive prefix */
 113 c 0110     i = index(fn,':');
 114 c 0120     if i = 0 then
 115 c 0129         drive = 0;
 116 c 0131     else
 117 c 0131     if i = 2 then
 118 c 013B         do;
 119 c 013B         /* convert character to drive code */
 120 c 013B         drive = index(upper,substr(fn,1,1));
 121 c 0153         if drive = 0 ! drive > 16 then
 122 c 016C             do;
 123 c 016C             put skip list('Bad Drive Name');
 124 c 0188             stop;
 125 c 018B             end;
 126 c 018B         fn = substr(fn,i+1);
 127 c 01A4         end;
 128 c 01A4 
 129 c 01A4     /* get file name and optional type */
 130 c 01A4     i = index(fn,'.');
 131 c 01B4     if i = 0 then
 132 c 01BD         do;
 133 c 01BD         /* no file type specified, use .DAT */
 134 c 01BD         fname = fn;
 135 c 01CA         ftype = 'DAT';
 136 c 01D9         end;
 137 c 01D9     else
 138 c 01D9         do;
 139 c 01D9         fname = substr(fn,1,i-1);
 140 c 01F5         ftype = substr(fn,i+1);
 141 c 020F         end;
 142 c 020F 
 143 c 020F     /* clear the extent field */
 144 c 020F     fext = 0;
 145 c 0214 
 146 c 0214     if open(addr(database)) = -1 then
 147 c 0225         do;
 148 c 0225         put skip list('Creating New Database');
 149 c 0241         if make(addr(database)) = -1 then
 150 c 0252             do;
 151 c 0252             put skip list('No Directory Space');
 152 c 026E             stop;
 153 c 0274             end;
 154 c 0274         end;
 155 c 0274     else
 156 c 0274         do;
 157 c 0274         call filsiz(addr(database));
 158 c 0280         put skip list('File Size:',rrec,' Records');
 159 c 02B2         end;
 160 c 02B2 
 161 c 02B2     /* main processing loop */
 162 c 02B2         do while('1'b);
 163 c 02B2         call setrec(addr(database));
 164 c 02BE         put skip list('Current Record',rrec);
 165 c 02E5         put skip list('Read(0),Write(1),Quit(2)? ');
 166 c 0301         get list(mode);
 167 c 031A         if mode < 2 then
 168 c 0322             do;
 169 c 0322             put skip list('Record Number? ');
 170 c 033E             get list(rrec);
 171 c 035B             rovf = 0;
 172 c 0360             end;
 173 c 0360         if mode = 0 then
 174 c 0367             do;
 175 c 0367             code = rdran(addr(database))%3b.html
 176 c 0376             if code = 0.html then
 177 c 037D                 do;
 178 c 037D                 if bitbuf(1) = '00'b4 then
 179 c 0386                     put skip list('Zero Record');
 180 c 03A5                 else
 181 c 03A5                     put skip list(buffer);
 182 c 03C2                 end;
 183 c 03C2             else
 184 c 03C2                 put skip list('Return Code',code);
 185 c 03F0             end;
 186 c 03F0         else
 187 c 03F0         if mode = 1 then
 188 c 03F7             do;
 189 c 03F7             put skip list('Data: ');
 190 c 0413             get list(buffer);
 191 c 042F             if zerofill then
 192 c 0436                 code = wrranz(addr(database))%3b.html
 193 c 0448             else
 194 c 0448                 code = wrran.html (addr(database));
 195 c 0457             if code ^= 0 then
 196 c 045E                 put skip list('Return Code',code);
 197 c 048C             end;
 198 c 048C         else
 199 c 048C         if mode = 2 then
 200 c 0494             do;
 201 c 0494             if close(addr(database)) = -1 then
 202 c 04A5                 put skip list('Read/Only');
 203 c 04C1             stop;
 204 c 04C7             end;
 205 c 04C7         end;
 206 a 04C7     end diorand;

CODE SIZE = 04C7
DATA AREA = 0183
END  COMPILATION


Next     Contents     Previous     Back to RMAC Page