util/ass/asprint.p

   1 #
   2 {$d+}
   3 program asprint(prog,output);
   4
   5 const
   6
   7   { header words }
   8   NTEXT   = 1;
   9   NDATA   = 2;
  10   NPROC   = 3;
  11   ENTRY   = 4;
  12   NLINE   = 5;
  13   SZDATA  = 6;
  14
  15   escape1 = 254;        { escape to secondary opcodes }
  16   escape2 = 255;        { escape to tertiary opcodes }
  17
  18 type
  19   byte=   0..255;           { memory is an array of bytes }
  20   adr=    {0..maxadr} long; { the range of addresses }
  21   word=   {0..maxuint} long;{ the range of unsigned integers }
  22   size=   0..32766;         { the range of sizes is the positive offsets }
  23   sword= {-signbit..maxsint} long; { the range of signed integers }
  24   full=  {-maxuint..maxuint} long; { intermediate results need this range }
  25   double={-maxdbl..maxdbl} long;   { double precision range }
  26   insclass=(prim,second,tert); { tells which opcode table is in use }
  27   instype=(implic,explic);  { does opcode have implicit or explicit operand }
  28   iflags= (mini,short,sbit,wbit,zbit,ibit);
  29   ifset=  set of iflags;
  30
  31   mnem = ( NON,
  32            AAR, ADF, ADI, ADP, ADS, ADU,XAND, ASP, ASS, BEQ,
  33            BGE, BGT, BLE, BLM, BLS, BLT, BNE, BRA, CAI, CAL,
  34            CFF, CFI, CFU, CIF, CII, CIU, CMF, CMI, CMP, CMS,
  35            CMU, COM, CSA, CSB, CUF, CUI, CUU, DCH, DEC, DEE,
  36            DEL, DUP, DUS, DVF, DVI, DVU, EXG, FEF, FIF, FIL,
  37            GTO, INC, INE, INL, INN, IOR, LAE, LAL, LAR, LDC,
  38            LDE, LDF, LDL, LFR, LIL, LIM, LIN, LNI, LOC, LOE,
  39            LOF, LOI, LOL, LOR, LOS, LPB, LPI, LXA, LXL, MLF,
  40            MLI, MLU, MON, NGF, NGI, NOP, RCK, RET, RMI, RMU,
  41            ROL, ROR, RTT, SAR, SBF, SBI, SBS, SBU, SDE, SDF,
  42            SDL,XSET, SIG, SIL, SIM, SLI, SLU, SRI, SRU, STE,
  43            STF, STI, STL, STR, STS, TEQ, TGE, TGT, TLE, TLT,
  44            TNE, TRP, XOR, ZEQ, ZER, ZGE, ZGT, ZLE, ZLT, ZNE,
  45            ZRE, ZRF, ZRL);
  46
  47   dispatch = record
  48                 iflag: ifset;
  49                 instr: mnem;
  50                 case instype of
  51                 implic: (implicit:sword);
  52                 explic: (ilength:byte);
  53              end;
  54
  55 var
  56   { variables indicating the size of words and addresses }
  57   wsize: integer;       { number of bytes in a word }
  58   asize: integer;       { number of bytes in an address }
  59   pdsize: integer;      { size of procedure descriptor in bytes = 2*asize }
  60
  61   pc,lb,sp,hp,pd: adr;  { internal machine registers }
  62   i: integer;           { integer scratch variable }
  63   s,t :word;            { scratch variables }
  64   sz:size;              { scratch variables }
  65   ss,st: sword;         { scratch variables }
  66   k :double;            { scratch variables }
  67   j:size;               { scratch variable used as index }
  68   a,b:adr;              { scratch variable used for addresses }
  69   dt,ds:double;         { scratch variables for double precision }
  70   found:boolean;        { scratch }
  71   opcode: byte;
  72   iclass: insclass;
  73   dispat: array[insclass, byte] of dispatch ;
  74   insr: mnem;           { holds the instructionnumber }
  75   header: array[1..8] of adr;
  76
  77   prog: file of byte;   { program and initialized data }
  78
  79 procedure getit;  { start the ball rolling }
  80 var cset:set of char;
  81     f:ifset;
  82     insno:byte;
  83     iclass: insclass;
  84     nops:integer;
  85     opcode:byte;
  86     i,j,n:integer;
  87     wtemp:sword;
  88     count:integer;
  89     repc:adr;
  90     nexta,firsta:adr;
  91     elem:byte;
  92     amount,ofst:size;
  93     c:char;
  94
  95     function readb(n:integer):double;
  96     var b:byte;
  97     begin
  98         if eof(prog) then
  99         begin writeln('Premature EOF on EM load file') ; halt end;
 100         read(prog,b); if n>1 then readb:=readb(n-1)*256+b else readb:=b
 101     end;
 102
 103     function readbyte:byte;
 104     begin readbyte:=readb(1) end;
 105
 106     procedure skipbyte;
 107     var dummy: byte;
 108     begin dummy:=readb(1) end;
 109
 110     function readword:word;
 111     begin readword:=readb(wsize) end;
 112
 113     function readadr:adr;
 114     begin readadr:=readb(asize) end;
 115
 116     function ifind(ordinal:byte):mnem;
 117     var loopvar:mnem;
 118         found:boolean;
 119     begin ifind:=NON;
 120       loopvar:=insr; found:=false;
 121       repeat
 122         if ordinal=ord(loopvar) then
 123           begin found:=true; ifind:=loopvar end;
 124         if loopvar<>ZRL then loopvar:=succ(loopvar) else loopvar:=NON;
 125       until found or (loopvar=insr) ;
 126    end;
 127
 128     procedure readhdr;
 129     type hdrw=0..32767 ; { 16 bit header words }
 130     var  hdr: hdrw;
 131          i: integer;
 132     begin
 133       for i:=0 to 7 do
 134       begin hdr:=readb(2);
 135         case i of
 136         0: if hdr<>3757 then { 07255 }
 137            begin writeln('Not an em load file'); halt end;
 138         1: writeln('Test flags: ',hdr);
 139         2: if hdr<>0 then
 140            begin writeln('Unsolved references: ',hdr) end;
 141         3: if hdr<>3 then
 142            begin writeln('Incorrect load file version') end;
 143         4: wsize:=hdr ;
 144         5: begin asize:=hdr ; pdsize:= asize+asize end;
 145         6,7:
 146            if hdr<>0 then
 147            begin writeln('First header entry ',i,', is ',hdr) end;
 148         end
 149       end;
 150       writeln('word size',wsize,', pointer size',asize)
 151     end;
 152
 153     procedure noinit;
 154     begin writeln('Illegal initialization'); halt end;
 155
 156     procedure readint(a:adr;s:size);
 157     const mrange = 4;
 158     var i:size;
 159         val:double;
 160         cont: array[1..mrange] of byte;
 161     begin { construct integer out of byte sequence }
 162       if s<=mrange then
 163       begin
 164           for i:=1 to s do cont[i]:=readbyte ;
 165           if cont[s]>=128 then val:=cont[s]-256 else val:=cont[s];
 166           for i:= s-1 downto 1 do val:= val*256 + cont[i];
 167           writeln(', value ',val)
 168       end
 169       else
 170       begin
 171           write(', bytes(little endian) ');
 172           for i:=1 to s do write(readbyte:4) ;
 173           writeln
 174       end
 175     end;
 176
 177     procedure readuns(a:adr;s:size);
 178     const mrange=3;
 179     var i:size;
 180         val:double;
 181         cont: array[1..mrange] of byte;
 182     begin { construct unsigned integer out of byte sequence }
 183       if s<=mrange then
 184       begin
 185           for i:=1 to s do cont[i]:=readbyte ;
 186           val:=0;
 187           for i:= s downto 1 do val:= val*256 + cont[i];
 188           writeln(', value ',val)
 189       end
 190       else
 191       begin
 192           write(', bytes(little endian) ');
 193           for i:=1 to s do write(readbyte:4) ;
 194           writeln
 195       end
 196     end;
 197
 198     procedure readfloat(a:adr;s:size);
 199     var i:size; b:byte;
 200     begin { construct float out of string}
 201       i:=0;
 202       repeat { eat the bytes, construct the value and intialize at a }
 203         write(chr(readbyte)); i:=i+1;
 204       until b=0 ;
 205     end;
 206
 207 begin
 208
 209 #ifdef INSRT
 210   { initialize tables }
 211   for iclass:=prim to tert do
 212     for i:=0 to 255 do
 213       with dispat[iclass][i] do
 214         begin instr:=NON; iflag:=[zbit] end;
 215
 216   { read instruction table file. see appendix B }
 217   { The table read here is a simple transformation of the table on page xx }
 218   { - instruction names were transformed to numbers }
 219   { - the '-' flag was transformed to an 'i' flag for 'w' type instructions }
 220   { - the 'S' flag was added for instructions having signed operands }
 221   reset(tables);
 222   insr:=NON;
 223   repeat
 224     read(tables,insno) ; cset:=[]; f:=[];
 225     insr:=ifind(insno);
 226     if insr=NON then begin writeln('Incorrect table'); halt end;
 227     repeat read(tables,c) until c<>' ' ;
 228     repeat
 229       cset:=cset+[c];
 230       read(tables,c)
 231     until c=' ' ;
 232     if 'm' in cset then f:=f+[mini];
 233     if 's' in cset then f:=f+[short];
 234     if '-' in cset then f:=f+[zbit];
 235     if 'i' in cset then f:=f+[ibit];
 236     if 'S' in cset then f:=f+[sbit];
 237     if 'w' in cset then f:=f+[wbit];
 238     if (mini in f) or (short in f) then read(tables,nops) else nops:=1 ;
 239     readln(tables,opcode);
 240     if ('4' in cset) or ('8' in cset) then
 241       begin iclass:=tert end
 242     else if 'e' in cset then
 243       begin iclass:=second end
 244     else iclass:=prim;
 245     for i:=0 to nops-1 do
 246     begin
 247       with dispat[iclass,opcode+i] do
 248       begin
 249         iflag:=f; instr:=insr;
 250         if '2' in cset      then ilength:=2
 251         else if 'u' in cset then ilength:=2
 252         else if '4' in cset then ilength:=4
 253         else if '8' in cset then ilength:=8
 254         else if (mini in f) or (short in f) then
 255           begin
 256             if 'N' in cset then wtemp:=-1-i else wtemp:=i ;
 257             if 'o' in cset then wtemp:=wtemp+1 ;
 258             if short in f then wtemp:=wtemp*256 ;
 259             implicit:=wtemp
 260           end
 261       end
 262     end
 263   until eof(tables);
 264
 265 #endif
 266   { read in program text, data and procedure descriptors }
 267   reset(prog);
 268   readhdr;                               { verify first header }
 269   for i:=1 to 8 do header[i]:=readadr;  { read second header }
 270   writeln('textsize ',header[NTEXT],', datasize ',header[SZDATA]);
 271   writeln('data descriptors: ',header[NDATA]);
 272   writeln('procedure descriptors: ',header[NPROC]);
 273   writeln('entry procedure: ',header[ENTRY]);
 274   if header[7]<>0 then writeln('Second header entry 7 is ',header[7]);
 275   if header[8]<>0 then writeln('Second header entry 8 is ',header[8]);
 276   { read program text }
 277   for i:=0 to header[NTEXT]-1 do skipbyte;
 278   { read data blocks }
 279   writeln; writeln('Data descriptors:');
 280   nexta:=0;
 281   for i:=1 to header[NDATA] do
 282     begin
 283       n:=readbyte;
 284       write(nexta:5,'-  ');
 285       if n<>0 then
 286         begin
 287           elem:=readbyte; firsta:=nexta;
 288           case n of
 289           1: { uninitialized words }
 290              begin
 291                  writeln(elem,' uninitialised word(s)');
 292                  nexta:= nexta+ elem*wsize ;
 293              end;
 294           2: { initialized bytes }
 295              begin
 296                  write(elem,' initialised byte(s)');
 297                  for j:=1 to elem do
 298                  begin
 299                      if j mod 10 = 1 then
 300                      begin writeln ; write(nexta:6,':') end ;
 301                      write(readbyte:4); nexta:=nexta+1
 302                  end;
 303                  writeln
 304               end;
 305           3: { initialized words }
 306              begin
 307                  write(elem,' initialised word(s)');
 308                  for j:=1 to elem do
 309                  begin
 310                      if j mod 8 = 1 then
 311                      begin writeln ; write(nexta:6,':') end ;
 312                      write(readword:9); nexta:=nexta+wsize
 313                  end;
 314                  writeln
 315               end;
 316           4,5: { instruction and data pointers }
 317              begin
 318                  if n=4 then
 319                      write(elem,' initialised data pointers')
 320                  else
 321                      write(elem,' initialised instruction pointers');
 322                  for j:=1 to elem do
 323                  begin
 324                      if j mod 8 = 1 then
 325                      begin writeln ; write(nexta:6,':') end ;
 326                      write(readadr:9); nexta:=nexta+asize
 327                  end;
 328                  writeln
 329               end;
 330           6: { signed integers }
 331              begin
 332                  write(elem,'-byte signed integer ');
 333                  readint(nexta,elem); nexta:=nexta+elem
 334              end;
 335           7: { unsigned integers }
 336              begin
 337                  write(elem,'-byte unsigned integer ');
 338                  readuns(nexta,elem); nexta:=nexta+elem
 339              end;
 340           8: { floating point numbers }
 341              begin
 342                  write(elem,'-byte floating point number ');
 343                  readfloat(nexta,elem); nexta:=nexta+elem
 344              end;
 345           end
 346         end
 347       else
 348         begin
 349           repc:=readadr;
 350           amount:=nexta-firsta;
 351           writeln(repc,' copies of the data from ',firsta:2,' to ',nexta:2);
 352           nexta:= nexta + repc*amount ;
 353         end
 354     end;
 355   if header[SZDATA]<>nexta then writeln('Data initialization error');
 356   { read descriptor table }
 357   pd:=header[NTEXT];
 358   for i:=1 to header[NPROC]*pdsize do skipbyte;
 359 end;
 360
 361 begin getit;
 362 #ifdef RTC
 363   repeat
 364     opcode := nextpc;       { fetch the first byte of the instruction }
 365     if opcode=escape1 then iclass:=second
 366     else if opcode=escape2 then iclass:=tert
 367     else iclass:=prim;
 368     if iclass<>prim then opcode := nextpc;
 369     with dispat[iclass][opcode] do
 370       begin insr:=instr;
 371         if not (zbit in iflag) then
 372           if ibit in iflag then k:=pop else
 373             begin
 374               if mini in iflag then k:=implicit else
 375                 begin
 376                   if short in iflag then k:=implicit+nextpc else
 377                     begin k:=nextpc;
 378                       if (sbit in iflag) and (k>=128) then k:=k-256;
 379                       for i:=2 to ilength do k:=256*k + nextpc
 380                     end
 381                 end;
 382               if wbit in iflag then k:=k*wsize;
 383             end
 384       end;
 385 #endif
 386 end.